Add more hash-like operations to id-table

The operations are ref!, set*, set*!, update, and
update!. Also bumps version number.

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.3.0.5")
+(define version "6.3.0.6")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/syntax/scribblings/id-table.scrbl

@@ -118,6 +118,16 @@ the @racket[failure] argument is applied if it is a procedure, or
 simply returned otherwise.
 }
 
+@defproc[(free-id-table-ref! [table mutable-free-id-table?]
+                             [id identifier?]
+                             [failure any/c])
+         any]{
+
+Like @racket[hash-ref!].
+
+@history[#:added "6.3.0.6"]
+}
+
 @defproc[(free-id-table-set! [table mutable-free-id-table?]
                              [id identifier?]
                              [v any/c])
@@ -134,6 +144,26 @@ Like @racket[hash-set!].
 Like @racket[hash-set].
 }
 
+@defproc[(free-id-table-set*! [table mutable-free-id-table?]
+                              [id identifier?]
+                              [v any/c] ...)
+         void?]{
+
+Like @racket[hash-set*!].
+
+@history[#:added "6.3.0.6"]
+}
+
+@defproc[(free-id-table-set* [table immutable-free-id-table?]
+                             [id identifier?]
+                             [v any/c] ...)
+         immutable-free-id-table?]{
+
+Like @racket[hash-set*].
+
+@history[#:added "6.3.0.6"]
+}
+
 @defproc[(free-id-table-remove! [table mutable-free-id-table?]
                                 [id identifier?])
          void?]{
@@ -148,6 +178,30 @@ Like @racket[hash-remove!].
 Like @racket[hash-remove].
 }
 
+@defproc[(free-id-table-update! [table mutable-free-id-table?]
+                                [id identifier?]
+                                [updater (any/c . -> . any/c)]
+                                [failure any/c
+                                 (lambda () (raise (make-exn:fail .....)))])
+         void?]{
+
+Like @racket[hash-update!].
+
+@history[#:added "6.3.0.6"]
+}
+
+@defproc[(free-id-table-update [table immutable-free-id-table?]
+                               [id identifier?]
+                               [updater (any/c . -> . any/c)]
+                               [failure any/c
+                                (lambda () (raise (make-exn:fail .....)))])
+         immutable-free-id-table?]{
+
+Like @racket[hash-update].
+
+@history[#:added "6.3.0.6"]
+}
+
 @defproc[(free-id-table-map [table free-id-table?]
                             [proc (-> identifier? any/c any)])
          list?]{
@@ -254,6 +308,10 @@ etc) can be used on bound-identifier tables.
                              [failure any/c
                               (lambda () (raise (make-exn:fail .....)))])
          any]
+@defproc[(bound-id-table-ref! [table mutable-bound-id-table?]
+                              [id identifier?]
+                              [failure any/c])
+         any]
 @defproc[(bound-id-table-set! [table mutable-bound-id-table?]
                               [id identifier?]
                               [v any/c])
@@ -262,12 +320,32 @@ etc) can be used on bound-identifier tables.
                              [id identifier?]
                              [v any/c])
          immutable-bound-id-table?]
+@defproc[(bound-id-table-set*! [table mutable-bound-id-table?]
+                               [id identifier?]
+                               [v any/c] ...)
+         void?]
+@defproc[(bound-id-table-set* [table immutable-bound-id-table?]
+                              [id identifier?]
+                              [v any/c] ...)
+         immutable-bound-id-table?]
 @defproc[(bound-id-table-remove! [table mutable-bound-id-table?]
                                  [id identifier?])
          void?]
 @defproc[(bound-id-table-remove [table immutable-bound-id-table?]
                                 [id identifier?])
          immutable-bound-id-table?]
+@defproc[(bound-id-table-update! [table mutable-bound-id-table?]
+                                 [id identifier?]
+                                 [updater (any/c . -> . any/c)]
+                                 [failure any/c
+                                  (lambda () (raise (make-exn:fail .....)))])
+         void?]
+@defproc[(bound-id-table-update [table immutable-bound-id-table?]
+                                [id identifier?]
+                                [updater (any/c . -> . any/c)]
+                                [failure any/c
+                                 (lambda () (raise (make-exn:fail .....)))])
+         immutable-bound-id-table?]
 @defproc[(bound-id-table-map [table bound-id-table?]
                              [proc (-> identifier? any/c any)])
          list?]
@@ -304,7 +382,10 @@ Like the procedures for free-identifier tables
 for bound-identifier tables, which use @racket[bound-identifier=?] to
 compare keys.
 
-@history[#:changed "6.3.0.3" "Added bound-id-table-keys, bound-id-table-values, in-bound-id-table."]
+@history[#:changed "6.3.0.3" "Added bound-id-table-keys, bound-id-table-values, in-bound-id-table."
+         #:changed "6.3.0.6"
+         @string-append{Added bound-id-table-ref!, bound-id-table-set*,
+                        bound-id-table-set*!, bound-id-table-update!, and bound-id-table-update}]
 }
 
 @close-eval[id-table-eval]

pkgs/racket-test-core/tests/racket/id-table-test.rktl

@@ -389,6 +389,41 @@
           (list (cons #'x 0) (cons #'x 1) (cons #'y 2))))
         bound-identifier=?))
 
+;; Tests for id-table-set*, set*!, update, update!, ref!
+(let ()
+  (define table (make-bound-id-table))
+  (define table2 (make-immutable-bound-id-table))
+  (define x0 #'x)
+  (define x1 ((make-syntax-introducer) x0))
+  (define y0 #'y)
+  (define y1 ((make-syntax-introducer) y0))
+
+  (test 0 bound-id-table-ref! table x0 0)
+  (test 1 bound-id-table-ref! table x1 1)
+  (test 0 bound-id-table-ref table x0)
+  (test 1 bound-id-table-ref (bound-id-table-update table2 y0 add1 0) y0)
+  (test 1 bound-id-table-ref (bound-id-table-set* table2 y0 0 y1 1) y1)
+  (test (void) bound-id-table-set*! table y0 1 y1 5)
+  (test (void) bound-id-table-update! table y0 add1 0)
+  (test 2 bound-id-table-ref table y0))
+
+(let ()
+  (define table (make-free-id-table))
+  (define table2 (make-immutable-free-id-table))
+  (define x0 #'x)
+  (define x1 #'x1)
+  (define y0 #'y)
+  (define y1 #'y1)
+
+  (test 0 free-id-table-ref! table x0 0)
+  (test 1 free-id-table-ref! table x1 1)
+  (test 0 free-id-table-ref table x0)
+  (test 1 free-id-table-ref (free-id-table-update table2 y0 add1 0) y0)
+  (test 1 free-id-table-ref (free-id-table-set* table2 y0 0 y1 1) y1)
+  (test (void) free-id-table-set*! table y0 1 y1 5)
+  (test (void) free-id-table-update! table y0 add1 0)
+  (test 2 free-id-table-ref table y0))
+
 (define-syntax name-for-boundmap-test 'dummy)
 (define-syntax alias-for-boundmap-test (make-rename-transformer #'name-for-boundmap-test))
 (define table (make-free-id-table))

racket/collects/syntax/id-table.rkt

@@ -197,6 +197,8 @@
           idtbl-set! idtbl-set
           idtbl-remove! idtbl-remove
           idtbl-set/constructor idtbl-remove/constructor
+          idtbl-set* idtbl-set*/constructor idtbl-set*! idtbl-ref!
+          idtbl-update idtbl-update/constructor idtbl-update!
           idtbl-count
           idtbl-iterate-first idtbl-iterate-next
           idtbl-iterate-key idtbl-iterate-value
@@ -232,6 +234,13 @@
              (idtbl-set/constructor d id v immutable-idtbl))
            (define (idtbl-remove d id)
              (idtbl-remove/constructor d id immutable-idtbl))
+           (define (idtbl-set* d . rst)
+             (apply idtbl-set*/constructor d immutable-idtbl rst))
+           (define not-given (gensym 'not-given))
+           (define (idtbl-update d id updater [default not-given])
+             (if (eq? default not-given)
+                 (idtbl-update/constructor d id updater immutable-idtbl)
+                 (idtbl-update/constructor d id updater immutable-idtbl default)))
            (define idtbl-immutable-methods
              (vector-immutable idtbl-ref
                                #f
@@ -279,6 +288,28 @@
              (-> mutable-idtbl? identifier? void?)]
             [idtbl-remove
              (-> immutable-idtbl? identifier? immutable-idtbl?)]
+            [idtbl-set*
+             (->* [immutable-idtbl?]
+                  #:rest (flat-rec-contract key-value-pairs
+                           (or/c null
+                                 (cons/c identifier? (cons/c any/c key-value-pairs))))
+                  immutable-idtbl?)]
+            [idtbl-set*!
+             (->* [mutable-idtbl?]
+                  #:rest (flat-rec-contract key-value-pairs
+                           (or/c null
+                                 (cons/c identifier? (cons/c any/c key-value-pairs))))
+                  void?)]
+            [idtbl-ref!
+             (-> mutable-idtbl? identifier? any/c any)]
+            [idtbl-update
+             (->* [immutable-idtbl? identifier? (-> any/c any/c)]
+                  [any/c]
+                  immutable-idtbl?)]
+            [idtbl-update!
+             (->* [mutable-idtbl? identifier? (-> any/c any/c)]
+                  [any/c]
+                  void?)]
             [idtbl-count
              (-> idtbl? exact-nonnegative-integer?)]
             [idtbl-iterate-first

racket/collects/syntax/private/id-table.rkt

@@ -136,6 +136,47 @@ The {key,value}-{in-out} functions should all return a chaperone of their argume
          (hash-remove (id-table-hash d) sym))
      phase)))
 
+(define (id-table-set*! who d identifier->symbol identifier=? . rst)
+  (let loop ([rst rst])
+    (cond [(null? rst) (void)]
+          [else
+           (id-table-set!
+            who d
+            (car rst) (cadr rst)
+            identifier->symbol identifier=?)
+           (loop (cddr rst))])))
+
+(define (id-table-set*/constructor who d constructor identifier->symbol identifier=? . rst)
+  (let loop ([d d] [rst rst])
+    (if (null? rst)
+        d
+        (loop (id-table-set/constructor
+               who d
+               (car rst) (cadr rst)
+               constructor identifier->symbol identifier=?)
+              (cddr rst)))))
+
+(define missing (gensym 'missing))
+(define (id-table-ref! who d id default identifier->symbol identifier=?)
+  (define entry (id-table-ref who d id missing identifier->symbol identifier=?))
+  (cond [(eq? entry missing)
+         (id-table-set! who d id default identifier->symbol identifier=?)
+         default]
+        [else entry]))
+
+(define (id-table-update/constructor who d id updater default constructor identifier->symbol identifier=?)
+  (define entry
+    (id-table-ref who d id default identifier->symbol identifier=?))
+  (id-table-set/constructor
+   who d id
+   (updater entry)
+   constructor identifier->symbol identifier=?))
+
+(define (id-table-update! who d id updater default identifier->symbol identifier=?)
+  (define entry
+    (id-table-ref who d id default identifier->symbol identifier=?))
+  (id-table-set! who d id (updater entry) identifier->symbol identifier=?))
+
 (define (id-table-count d)
   (for/sum ([(k v) (in-hash (id-table-hash d))])
      (length v)))
@@ -312,6 +353,8 @@ Notes (FIXME?):
           idtbl-set! idtbl-set
           idtbl-remove! idtbl-remove
           idtbl-set/constructor idtbl-remove/constructor
+          idtbl-set* idtbl-set*/constructor idtbl-set*! idtbl-ref!
+          idtbl-update idtbl-update/constructor idtbl-update!
           idtbl-count
           idtbl-iterate-first idtbl-iterate-next
           idtbl-iterate-key idtbl-iterate-value
@@ -347,6 +390,16 @@ Notes (FIXME?):
              (id-table-remove/constructor 'idtbl-remove d id constructor identifier->symbol identifier=?))
            (define (idtbl-remove d id)
              (idtbl-remove/constructor d id immutable-idtbl))
+           (define (idtbl-set*/constructor d constructor . rst)
+             (apply id-table-set*/constructor 'idtbl-set* d constructor identifier->symbol identifier=? rst))
+           (define (idtbl-set*! d . rst)
+             (apply id-table-set*! 'idtbl-set*! d identifier->symbol identifier=? rst))
+           (define (idtbl-ref! d id default)
+             (id-table-ref! 'idtbl-ref! d id default identifier->symbol identifier=?))
+           (define (idtbl-update/constructor d id updater constructor [default not-given])
+             (id-table-update/constructor 'idtbl-update d id updater default constructor identifier->symbol identifier=?))
+           (define (idtbl-update! d id updater [default not-given])
+             (id-table-update! 'idtbl-update! d id updater default identifier->symbol identifier=?))
            (define (idtbl-count d)
              (id-table-count d))
            (define (idtbl-for-each d p)
@@ -417,6 +470,9 @@ Notes (FIXME?):
                     idtbl-set
                     idtbl-remove!
                     idtbl-remove
+                    idtbl-set*!
+                    idtbl-ref!
+                    idtbl-update!
                     idtbl-count
                     idtbl-iterate-first
                     idtbl-iterate-next
@@ -430,7 +486,9 @@ Notes (FIXME?):
 
                     ;; just for use/extension by syntax/id-table
                     idtbl-set/constructor
+                    idtbl-set*/constructor
                     idtbl-remove/constructor
+                    idtbl-update/constructor
                     idtbl-mutable-methods
                     mutable-idtbl
                     immutable-idtbl)))]))

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.3.0.5"
+#define MZSCHEME_VERSION "6.3.0.6"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 3
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 4
+#define MZSCHEME_VERSION_W 6
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)