[Emacs-diffs] /srv/bzr/emacs/trunk r103943: gnus-registry.el, registry.el: Silence the byte compiler.

[Katsumi Yamaoka]

------------------------------------------------------------
revno: 103943
committer: Katsumi Yamaoka <address@hidden>
branch nick: trunk
timestamp: Mon 2011-04-18 22:59:02 +0000
message:
  gnus-registry.el, registry.el: Silence the byte compiler.
  
  gnus-registry.el: Eliminate cl functions.
   (gnus-registry-sort-addresses): New function that replaces mapcan.
   (gnus-registry-action, gnus-registry-spool-action)
   (gnus-registry-split-fancy-with-parent)
   (gnus-registry-fetch-recipients-fast): Use it.
   (gnus-registry-import-eld): Replace delete* with dolist + delq.
  registry.el (initialize-instance, registry-lookup)
   (registry-lookup-breaks-before-lexbind, registry-lookup-secondary)
   (registry-lookup-secondary-value, registry-search, registry-delete)
   (registry-insert, registry-reindex, registry-size, registry-prune):
   Use eval-and-compile.
modified:
  lisp/gnus/ChangeLog
  lisp/gnus/gnus-registry.el
  lisp/gnus/registry.el

=== modified file 'lisp/gnus/ChangeLog'
--- a/lisp/gnus/ChangeLog       2011-04-16 06:56:17 +0000
+++ b/lisp/gnus/ChangeLog       2011-04-18 22:59:02 +0000
@@ -1,3 +1,18 @@
+2011-04-18  Katsumi Yamaoka  <address@hidden>
+
+       * gnus-registry.el: Eliminate cl functions.
+       (gnus-registry-sort-addresses): New function that replaces mapcan.
+       (gnus-registry-action, gnus-registry-spool-action)
+       (gnus-registry-split-fancy-with-parent)
+       (gnus-registry-fetch-recipients-fast): Use it.
+       (gnus-registry-import-eld): Replace delete* with dolist + delq.
+
+       * registry.el (initialize-instance, registry-lookup)
+       (registry-lookup-breaks-before-lexbind, registry-lookup-secondary)
+       (registry-lookup-secondary-value, registry-search, registry-delete)
+       (registry-insert, registry-reindex, registry-size, registry-prune):
+       Use eval-and-compile.
+
 2011-04-16  Teodor Zlatanov  <address@hidden>
 
        * registry.el (registry-reindex): New method to recreate the secondary

=== modified file 'lisp/gnus/gnus-registry.el'
--- a/lisp/gnus/gnus-registry.el        2011-04-16 06:56:17 +0000
+++ b/lisp/gnus/gnus-registry.el        2011-04-18 22:59:02 +0000
@@ -303,15 +303,9 @@
 (defun gnus-registry-action (action data-header from &optional to method)
   (let* ((id (mail-header-id data-header))
          (subject (mail-header-subject data-header))
-         (recipients (sort (mapcan 'gnus-registry-extract-addresses
-                                   (list
-                                    (or (ignore-errors
-                                          (mail-header "Cc" data-header))
-                                        "")
-                                    (or (ignore-errors
-                                          (mail-header "To" data-header))
-                                        "")))
-                           'string-lessp))
+         (recipients (gnus-registry-sort-addresses
+                     (or (ignore-errors (mail-header "Cc" data-header)) "")
+                     (or (ignore-errors (mail-header "To" data-header)) "")))
          (sender (nth 0 (gnus-registry-extract-addresses
                          (mail-header-from data-header))))
          (from (gnus-group-guess-full-name-from-command-method from))
@@ -329,11 +323,9 @@
 (defun gnus-registry-spool-action (id group &optional subject sender 
recipients)
   (let ((to (gnus-group-guess-full-name-from-command-method group))
         (recipients (or recipients
-                        (sort (mapcan 'gnus-registry-extract-addresses
-                                      (list
-                                       (or (message-fetch-field "cc") "")
-                                       (or (message-fetch-field "to") "")))
-                              'string-lessp)))
+                       (gnus-registry-sort-addresses
+                        (or (message-fetch-field "cc") "")
+                        (or (message-fetch-field "to") ""))))
         (subject (or subject (message-fetch-field "subject")))
         (sender (or sender (message-fetch-field "from"))))
     (when (and (stringp id) (string-match "\r$" id))
@@ -409,11 +401,9 @@
          ;; these may not be used, but the code is cleaner having them up here
          (sender (gnus-string-remove-all-properties
                   (message-fetch-field "from")))
-         (recipients (sort (mapcan 'gnus-registry-extract-addresses
-                                   (list
-                                    (or (message-fetch-field "cc") "")
-                                    (or (message-fetch-field "to") "")))
-                           'string-lessp))
+         (recipients (gnus-registry-sort-addresses
+                     (or (message-fetch-field "cc") "")
+                     (or (message-fetch-field "to") "")))
          (subject (gnus-string-remove-all-properties
                    (gnus-registry-simplify-subject
                     (message-fetch-field "subject"))))
@@ -719,6 +709,11 @@
                (format "%s <%s>" name addr))))
           (mail-extract-address-components text t)))
 
+(defun gnus-registry-sort-addresses (&rest addresses)
+  "Return a normalized and sorted list of ADDRESSES."
+  (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses))
+       'string-lessp))
+
 (defun gnus-registry-simplify-subject (subject)
   (if (stringp subject)
       (gnus-simplify-subject subject)
@@ -738,15 +733,9 @@
   (gnus-registry-fetch-header-fast "from" article))
 
 (defun gnus-registry-fetch-recipients-fast (article)
-  (sort (mapcan 'gnus-registry-extract-addresses
-                (list
-                 (or (ignore-errors
-                       (gnus-registry-fetch-header-fast "Cc" article))
-                     "")
-                 (or (ignore-errors
-                       (gnus-registry-fetch-header-fast "To" article))
-                     "")))
-        'string-lessp))
+  (gnus-registry-sort-addresses
+   (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "")
+   (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
 
 (defun gnus-registry-fetch-header-fast (article header)
   "Fetch the HEADER quickly, using the internal gnus-data-list function"
@@ -982,7 +971,8 @@
                              collect p))
                extra-cell key val)
           ;; remove all the strings from the entry
-          (delete* nil rest :test (lambda (a b) (stringp b)))
+          (dolist (elem rest)
+           (if (stringp elem) (setq rest (delq elem rest))))
           (gnus-registry-set-id-key id 'group groups)
           ;; just use the first extra element
           (setq rest (car-safe rest))

=== modified file 'lisp/gnus/registry.el'
--- a/lisp/gnus/registry.el     2011-04-16 06:56:17 +0000
+++ b/lisp/gnus/registry.el     2011-04-18 22:59:02 +0000
@@ -131,58 +131,60 @@
          :type hash-table
          :documentation "The data hashtable.")))
 
-(defmethod initialize-instance :AFTER ((this registry-db) slots)
-  "Set value of data slot of THIS after initialization."
-  (with-slots (data tracker) this
-    (unless (member :data slots)
-      (setq data (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)))
-    (unless (member :tracker slots)
-      (setq tracker (make-hash-table :size 100 :rehash-size 2.0)))))
-
-(defmethod registry-lookup ((db registry-db) keys)
-  "Search for KEYS in the registry-db THIS.
-Returns a alist of the key followed by the entry in a list, not a cons cell."
-  (let ((data (oref db :data)))
-    (delq nil
-          (mapcar
-           (lambda (k)
-             (when (gethash k data)
-               (list k (gethash k data))))
-           keys))))
-
-(defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys)
-  "Search for KEYS in the registry-db THIS.
-Returns a alist of the key followed by the entry in a list, not a cons cell."
-  (let ((data (oref db :data)))
-    (delq nil
-          (loop for key in keys
-                when (gethash key data)
-                collect (list key (gethash key data))))))
-
-(defmethod registry-lookup-secondary ((db registry-db) tracksym
-                                      &optional create)
-  "Search for TRACKSYM in the registry-db THIS.
+(eval-and-compile
+  (defmethod initialize-instance :AFTER ((this registry-db) slots)
+    "Set value of data slot of THIS after initialization."
+    (with-slots (data tracker) this
+      (unless (member :data slots)
+       (setq data
+             (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)))
+      (unless (member :tracker slots)
+       (setq tracker (make-hash-table :size 100 :rehash-size 2.0)))))
+
+  (defmethod registry-lookup ((db registry-db) keys)
+    "Search for KEYS in the registry-db THIS.
+Returns a alist of the key followed by the entry in a list, not a cons cell."
+    (let ((data (oref db :data)))
+      (delq nil
+           (mapcar
+            (lambda (k)
+              (when (gethash k data)
+                (list k (gethash k data))))
+            keys))))
+
+  (defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys)
+    "Search for KEYS in the registry-db THIS.
+Returns a alist of the key followed by the entry in a list, not a cons cell."
+    (let ((data (oref db :data)))
+      (delq nil
+           (loop for key in keys
+                 when (gethash key data)
+                 collect (list key (gethash key data))))))
+
+  (defmethod registry-lookup-secondary ((db registry-db) tracksym
+                                       &optional create)
+    "Search for TRACKSYM in the registry-db THIS.
 When CREATE is not nil, create the secondary index hashtable if needed."
-  (let ((h (gethash tracksym (oref db :tracker))))
-    (if h
-        h
-      (when create
-        (puthash tracksym
-                 (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
-                 (oref db :tracker))
-        (gethash tracksym (oref db :tracker))))))
+    (let ((h (gethash tracksym (oref db :tracker))))
+      (if h
+         h
+       (when create
+         (puthash tracksym
+                  (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
+                  (oref db :tracker))
+         (gethash tracksym (oref db :tracker))))))
 
-(defmethod registry-lookup-secondary-value ((db registry-db) tracksym val
-                                            &optional set)
-  "Search for TRACKSYM with value VAL in the registry-db THIS.
+  (defmethod registry-lookup-secondary-value ((db registry-db) tracksym val
+                                             &optional set)
+    "Search for TRACKSYM with value VAL in the registry-db THIS.
 When SET is not nil, set it for VAL (use t for an empty list)."
-  ;; either we're asked for creation or there should be an existing index
-  (when (or set (registry-lookup-secondary db tracksym))
-    ;; set the entry if requested,
-    (when set
-      (puthash val (if (eq t set) '() set)
-               (registry-lookup-secondary db tracksym t)))
-    (gethash val (registry-lookup-secondary db tracksym))))
+    ;; either we're asked for creation or there should be an existing index
+    (when (or set (registry-lookup-secondary db tracksym))
+      ;; set the entry if requested,
+      (when set
+       (puthash val (if (eq t set) '() set)
+                (registry-lookup-secondary db tracksym t)))
+      (gethash val (registry-lookup-secondary db tracksym)))))
 
 (defun registry--match (mode entry check-list)
   ;; for all members
@@ -204,129 +206,133 @@
       (or found
           (registry--match mode entry (cdr-safe check-list))))))
 
-(defmethod registry-search ((db registry-db) &rest spec)
-  "Search for SPEC across the registry-db THIS.
+(eval-and-compile
+  (defmethod registry-search ((db registry-db) &rest spec)
+    "Search for SPEC across the registry-db THIS.
 For example calling with :member '(a 1 2) will match entry '((a 3 1)).
 Calling with :all t (any non-nil value) will match all.
 Calling with :regex '\(a \"h.llo\") will match entry '((a \"hullo\" \"bye\").
 The test order is to check :all first, then :member, then :regex."
-  (when db
-    (let ((all (plist-get spec :all))
-          (member (plist-get spec :member))
-          (regex (plist-get spec :regex)))
-      (loop for k being the hash-keys of (oref db :data) using (hash-values v)
-            when (or
-                  ;; :all non-nil returns all
-                  all
-                  ;; member matching
-                  (and member (registry--match :member v member))
-                  ;; regex matching
-                  (and regex (registry--match :regex v regex)))
-            collect k))))
+    (when db
+      (let ((all (plist-get spec :all))
+           (member (plist-get spec :member))
+           (regex (plist-get spec :regex)))
+       (loop for k being the hash-keys of (oref db :data)
+             using (hash-values v)
+             when (or
+                   ;; :all non-nil returns all
+                   all
+                   ;; member matching
+                   (and member (registry--match :member v member))
+                   ;; regex matching
+                   (and regex (registry--match :regex v regex)))
+             collect k))))
 
-(defmethod registry-delete ((db registry-db) keys assert &rest spec)
-  "Delete KEYS from the registry-db THIS.
+  (defmethod registry-delete ((db registry-db) keys assert &rest spec)
+    "Delete KEYS from the registry-db THIS.
 If KEYS is nil, use SPEC to do a search.
 Updates the secondary ('tracked') indices as well.
 With assert non-nil, errors out if the key does not exist already."
-  (let* ((data (oref db :data))
-         (keys (or keys
-                   (apply 'registry-search db spec)))
-         (tracked (oref db :tracked)))
-
-    (dolist (key keys)
-      (let ((entry (gethash key data)))
-        (when assert
-          (assert entry nil
-                  "Key %s does not exists in database" key))
-        ;; clean entry from the secondary indices
-        (dolist (tr tracked)
-          ;; is this tracked symbol indexed?
-          (when (registry-lookup-secondary db tr)
-            ;; for every value in the entry under that key...
-            (dolist (val (cdr-safe (assq tr entry)))
-              (let* ((value-keys (registry-lookup-secondary-value db tr val)))
-              (when (member key value-keys)
-                ;; override the previous value
-                (registry-lookup-secondary-value
-                 db tr val
-                 ;; with the indexed keys MINUS the current key
-                 ;; (we pass t when the list is empty)
-                 (or (delete key value-keys) t)))))))
-        (remhash key data)))
-    keys))
-
-(defmethod registry-insert ((db registry-db) key entry)
-  "Insert ENTRY under KEY into the registry-db THIS.
+    (let* ((data (oref db :data))
+          (keys (or keys
+                    (apply 'registry-search db spec)))
+          (tracked (oref db :tracked)))
+
+      (dolist (key keys)
+       (let ((entry (gethash key data)))
+         (when assert
+           (assert entry nil
+                   "Key %s does not exists in database" key))
+         ;; clean entry from the secondary indices
+         (dolist (tr tracked)
+           ;; is this tracked symbol indexed?
+           (when (registry-lookup-secondary db tr)
+             ;; for every value in the entry under that key...
+             (dolist (val (cdr-safe (assq tr entry)))
+               (let* ((value-keys (registry-lookup-secondary-value
+                                   db tr val)))
+                 (when (member key value-keys)
+                   ;; override the previous value
+                   (registry-lookup-secondary-value
+                    db tr val
+                    ;; with the indexed keys MINUS the current key
+                    ;; (we pass t when the list is empty)
+                    (or (delete key value-keys) t)))))))
+         (remhash key data)))
+      keys))
+
+  (defmethod registry-insert ((db registry-db) key entry)
+    "Insert ENTRY under KEY into the registry-db THIS.
 Updates the secondary ('tracked') indices as well.
 Errors out if the key exists already."
 
-  (assert (not (gethash key (oref db :data))) nil
-          "Key already exists in database")
-
-  (assert (< (registry-size db)
-             (oref db :max-hard))
-          nil
-          "max-hard size limit reached")
-
-  ;; store the entry
-  (puthash key entry (oref db :data))
-
-  ;; store the secondary indices
-  (dolist (tr (oref db :tracked))
-    ;; for every value in the entry under that key...
-    (dolist (val (cdr-safe (assq tr entry)))
-      (let* ((value-keys (registry-lookup-secondary-value db tr val)))
-        (pushnew key value-keys :test 'equal)
-        (registry-lookup-secondary-value db tr val value-keys))))
-  entry)
-
-(defmethod registry-reindex ((db registry-db))
-  "Rebuild the secondary indices of registry-db THIS."
-  (let ((count 0)
-        (expected (* (length (oref db :tracked)) (registry-size db))))
+    (assert (not (gethash key (oref db :data))) nil
+           "Key already exists in database")
+
+    (assert (< (registry-size db)
+              (oref db :max-hard))
+           nil
+           "max-hard size limit reached")
+
+    ;; store the entry
+    (puthash key entry (oref db :data))
+
+    ;; store the secondary indices
     (dolist (tr (oref db :tracked))
-      (let (values)
-        (maphash
-         (lambda (key v)
-           (incf count)
-           (when (and (< 0 expected)
-                      (= 0 (mod count 1000)))
-             (message "reindexing: %d of %d (%.2f%%)"
-                      count expected (/ (* 1000 count) expected)))
-           (dolist (val (cdr-safe (assq tr v)))
-             (let* ((value-keys (registry-lookup-secondary-value db tr val)))
-               (push key value-keys)
-               (registry-lookup-secondary-value db tr val value-keys))))
-         (oref db :data))))))
-
-(defmethod registry-size ((db registry-db))
-  "Returns the size of the registry-db object THIS.
+      ;; for every value in the entry under that key...
+      (dolist (val (cdr-safe (assq tr entry)))
+       (let* ((value-keys (registry-lookup-secondary-value db tr val)))
+         (pushnew key value-keys :test 'equal)
+         (registry-lookup-secondary-value db tr val value-keys))))
+    entry)
+
+  (defmethod registry-reindex ((db registry-db))
+    "Rebuild the secondary indices of registry-db THIS."
+    (let ((count 0)
+         (expected (* (length (oref db :tracked)) (registry-size db))))
+      (dolist (tr (oref db :tracked))
+       (let (values)
+         (maphash
+          (lambda (key v)
+            (incf count)
+            (when (and (< 0 expected)
+                       (= 0 (mod count 1000)))
+              (message "reindexing: %d of %d (%.2f%%)"
+                       count expected (/ (* 1000 count) expected)))
+            (dolist (val (cdr-safe (assq tr v)))
+              (let* ((value-keys (registry-lookup-secondary-value db tr val)))
+                (push key value-keys)
+                (registry-lookup-secondary-value db tr val value-keys))))
+          (oref db :data))))))
+
+  (defmethod registry-size ((db registry-db))
+    "Returns the size of the registry-db object THIS.
 This is the key count of the :data slot."
-  (hash-table-count (oref db :data)))
+    (hash-table-count (oref db :data)))
 
-(defmethod registry-prune ((db registry-db))
-  "Prunes the registry-db object THIS.
+  (defmethod registry-prune ((db registry-db))
+    "Prunes the registry-db object THIS.
 Removes only entries without the :precious keys."
-  (let* ((precious (oref db :precious))
-         (precious-p (lambda (entry-key) (cdr (memq (car entry-key) 
precious))))
-         (data (oref db :data))
-         (limit (oref db :max-soft))
-         (size (registry-size db))
-         (candidates (loop for k being the hash-keys of data
-                           using (hash-values v)
-                           when (notany precious-p v)
-                           collect k))
-         (candidates-count (length candidates))
-         ;; are we over max-soft?
-         (prune-needed (> size limit)))
-
-    ;; while we have more candidates than we need to remove...
-    (while (and (> candidates-count (- size limit)) candidates)
-      (decf candidates-count)
-      (setq candidates (cdr candidates)))
-
-    (registry-delete db candidates nil)))
+    (let* ((precious (oref db :precious))
+          (precious-p (lambda (entry-key)
+                        (cdr (memq (car entry-key) precious))))
+          (data (oref db :data))
+          (limit (oref db :max-soft))
+          (size (registry-size db))
+          (candidates (loop for k being the hash-keys of data
+                            using (hash-values v)
+                            when (notany precious-p v)
+                            collect k))
+          (candidates-count (length candidates))
+          ;; are we over max-soft?
+          (prune-needed (> size limit)))
+
+      ;; while we have more candidates than we need to remove...
+      (while (and (> candidates-count (- size limit)) candidates)
+       (decf candidates-count)
+       (setq candidates (cdr candidates)))
+
+      (registry-delete db candidates nil))))
 
 (ert-deftest registry-instantiation-test ()
   (should (registry-db "Testing")))