(x-gtk-stock-cache): New hash table.

(x-gtk-map-stock): Perform caching to prevent excess consing during

diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el
index dc491704249f50963c54328277ffa59c97403170..694e51c6a17c2ce809039b3194eb60e47fbd84e8 100644 (file)
--- a/lisp/term/x-win.el
+++ b/lisp/term/x-win.el
@@ -1674,21 +1674,31 @@ If you don't want stock icons, set the variable to nil."
                                       (string :tag "Stock/named")))))
   :group 'x)
 
+(defconst x-gtk-stock-cache (make-hash-table :weakness t :test 'equal))
+
 (defun x-gtk-map-stock (file)
-  "Map icon with file name FILE to a Gtk+ stock name, using `x-gtk-stock-map'."
-  (if (stringp file)
-      (save-match-data
-       (let* ((file-sans (file-name-sans-extension file))
-              (key (and (string-match "/\\([^/]+/[^/]+/[^/]+$\\)" file-sans)
-                        (match-string 1 file-sans)))
-              (value))
-         (mapc (lambda (elem)
-                 (let ((assoc (if (symbolp elem) (symbol-value elem) elem)))
-                   (or value (setq value (assoc-string (or key file-sans)
-                                                       assoc)))))
-               icon-map-list)
-         (and value (cdr value))))
-    nil))
+  "Map icon with file name FILE to a Gtk+ stock name.
+This uses `icon-map-list' to map icon file names to stock icon names."
+  (when (stringp file)
+    (or (gethash file x-gtk-stock-cache)
+       (puthash
+        file
+        (save-match-data
+          (let* ((file-sans (file-name-sans-extension file))
+                 (key (and (string-match "/\\([^/]+/[^/]+/[^/]+$\\)"
+                                         file-sans)
+                           (match-string 1 file-sans)))
+                 (icon-map icon-map-list)
+                 elem value)
+            (while (and (null value) icon-map)
+              (setq elem (car icon-map)
+                    value (assoc-string (or key file-sans)
+                                        (if (symbolp elem)
+                                            (symbol-value elem)
+                                          elem))
+                    icon-map (cdr icon-map)))
+            (and value (cdr value))))
+        x-gtk-stock-cache))))
 
 (provide 'x-win)