[COMMIT] Don't uselessly call #'nreverse, #'hash-table-key-list and friends.
14 years
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1284651987 -3600
# Node ID 2def0d83a5e3d71e94169949edcc4c8ebbcdea63
# Parent 3acaa0fc09be8f63648b7b07d7bef4b63e729829
Don't uselessly call #'nreverse, #'hash-table-key-list and friends.
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* hash-table.el (hash-table-key-list, hash-table-value-list)
(hash-table-key-value-alist, hash-table-key-value-plist):
Remove some useless #'nreverse calls in these files; our hash
tables have no order, it's not helpful to pretend they do.
* behavior.el (read-behavior):
Do the same in this file, in some code evidently copied from
hash-table.el.
diff -r 3acaa0fc09be -r 2def0d83a5e3 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 15:58:10 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 16:46:27 2010 +0100
＠＠ -1,3 +1,13 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * hash-table.el (hash-table-key-list, hash-table-value-list)
+ (hash-table-key-value-alist, hash-table-key-value-plist):
+ Remove some useless #'nreverse calls in these files; our hash
+ tables have no order, it's not helpful to pretend they do.
+ * behavior.el (read-behavior):
+ Do the same in this file, in some code evidently copied from
+ hash-table.el.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* info.el (Info-insert-dir):
diff -r 3acaa0fc09be -r 2def0d83a5e3 lisp/behavior.el
--- a/lisp/behavior.el Thu Sep 16 15:58:10 2010 +0100
+++ b/lisp/behavior.el Thu Sep 16 16:46:27 2010 +0100
＠＠ -349,15 +349,11 ＠＠
(let ((result
(completing-read
prompt
- (let ((table (let (lis)
- (maphash #'(lambda (key val)
- (push (cons key val) lis))
- behavior-hash-table)
- (nreverse lis))))
- (mapc #'(lambda (aentry)
- (setcar aentry (symbol-name (car aentry))))
- table)
- table)
+ (let (list)
+ (maphash #'(lambda (key value)
+ (push (cons (symbol-name key) value) list))
+ behavior-hash-table)
+ list)
nil must-match initial-contents (or history 'behavior-history)
default-value)))
(if (and result (stringp result))
diff -r 3acaa0fc09be -r 2def0d83a5e3 lisp/hash-table.el
--- a/lisp/hash-table.el Thu Sep 16 15:58:10 2010 +0100
+++ b/lisp/hash-table.el Thu Sep 16 16:46:27 2010 +0100
＠＠ -37,34 +37,27 ＠＠
(defun hash-table-key-list (hash-table)
"Return a list of all keys in HASH-TABLE."
- (let (lis)
- (maphash #'(lambda (key val)
- (push key lis))
- hash-table)
- (nreverse lis)))
+ (let (list)
+ (maphash #'(lambda (key value) (push key list)) hash-table)
+ list))
(defun hash-table-value-list (hash-table)
"Return a list of all values in HASH-TABLE."
- (let (lis)
- (maphash #'(lambda (key val)
- (push val lis))
- hash-table)
- (nreverse lis)))
+ (let (list)
+ (maphash #'(lambda (key value) (push value list)) hash-table)
+ list))
(defun hash-table-key-value-alist (hash-table)
"Return an alist of (KEY . VALUE) for all keys and values in HASH-TABLE."
- (let (lis)
- (maphash #'(lambda (key val)
- (push (cons key val) lis))
+ (let (list)
+ (maphash #'(lambda (key value) (setq list (acons key value list)))
hash-table)
- (nreverse lis)))
+ list))
(defun hash-table-key-value-plist (hash-table)
"Return a plist for all keys and values in HASH-TABLE.
A plist is a simple list containing alternating keys and values."
- (let (lis)
- (maphash #'(lambda (key val)
- (push key lis)
- (push val lis))
+ (let (list)
+ (maphash #'(lambda (key value) (setq list (list* key value list)))
hash-table)
- (nreverse lis)))
+ list))
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Don't uselessly call #'nreverse, #'hash-table-key-list and friends.
14 years
Aidan Kehoe
Aidan Kehoe
changeset: 5271:2def0d83a5e3
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 16:46:27 2010 +0100
files: lisp/ChangeLog lisp/behavior.el lisp/hash-table.el
description:
Don't uselessly call #'nreverse, #'hash-table-key-list and friends.
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* hash-table.el (hash-table-key-list, hash-table-value-list)
(hash-table-key-value-alist, hash-table-key-value-plist):
Remove some useless #'nreverse calls in these files; our hash
tables have no order, it's not helpful to pretend they do.
* behavior.el (read-behavior):
Do the same in this file, in some code evidently copied from
hash-table.el.
diff -r 3acaa0fc09be -r 2def0d83a5e3 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 15:58:10 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 16:46:27 2010 +0100
＠＠ -1,3 +1,13 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * hash-table.el (hash-table-key-list, hash-table-value-list)
+ (hash-table-key-value-alist, hash-table-key-value-plist):
+ Remove some useless #'nreverse calls in these files; our hash
+ tables have no order, it's not helpful to pretend they do.
+ * behavior.el (read-behavior):
+ Do the same in this file, in some code evidently copied from
+ hash-table.el.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* info.el (Info-insert-dir):
diff -r 3acaa0fc09be -r 2def0d83a5e3 lisp/behavior.el
--- a/lisp/behavior.el Thu Sep 16 15:58:10 2010 +0100
+++ b/lisp/behavior.el Thu Sep 16 16:46:27 2010 +0100
＠＠ -349,15 +349,11 ＠＠
(let ((result
(completing-read
prompt
- (let ((table (let (lis)
- (maphash #'(lambda (key val)
- (push (cons key val) lis))
- behavior-hash-table)
- (nreverse lis))))
- (mapc #'(lambda (aentry)
- (setcar aentry (symbol-name (car aentry))))
- table)
- table)
+ (let (list)
+ (maphash #'(lambda (key value)
+ (push (cons (symbol-name key) value) list))
+ behavior-hash-table)
+ list)
nil must-match initial-contents (or history 'behavior-history)
default-value)))
(if (and result (stringp result))
diff -r 3acaa0fc09be -r 2def0d83a5e3 lisp/hash-table.el
--- a/lisp/hash-table.el Thu Sep 16 15:58:10 2010 +0100
+++ b/lisp/hash-table.el Thu Sep 16 16:46:27 2010 +0100
＠＠ -37,34 +37,27 ＠＠
(defun hash-table-key-list (hash-table)
"Return a list of all keys in HASH-TABLE."
- (let (lis)
- (maphash #'(lambda (key val)
- (push key lis))
- hash-table)
- (nreverse lis)))
+ (let (list)
+ (maphash #'(lambda (key value) (push key list)) hash-table)
+ list))
(defun hash-table-value-list (hash-table)
"Return a list of all values in HASH-TABLE."
- (let (lis)
- (maphash #'(lambda (key val)
- (push val lis))
- hash-table)
- (nreverse lis)))
+ (let (list)
+ (maphash #'(lambda (key value) (push value list)) hash-table)
+ list))
(defun hash-table-key-value-alist (hash-table)
"Return an alist of (KEY . VALUE) for all keys and values in HASH-TABLE."
- (let (lis)
- (maphash #'(lambda (key val)
- (push (cons key val) lis))
+ (let (list)
+ (maphash #'(lambda (key value) (setq list (acons key value list)))
hash-table)
- (nreverse lis)))
+ list))
(defun hash-table-key-value-plist (hash-table)
"Return a plist for all keys and values in HASH-TABLE.
A plist is a simple list containing alternating keys and values."
- (let (lis)
- (maphash #'(lambda (key val)
- (push key lis)
- (push val lis))
+ (let (list)
+ (maphash #'(lambda (key value) (setq list (list* key value list)))
hash-table)
- (nreverse lis)))
+ list))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Use #'some, #'every, etc. for composing boolean operations on lists.
14 years
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1284649090 -3600
# Node ID 3acaa0fc09be8f63648b7b07d7bef4b63e729829
# Parent 90a0084b3541132a577136fc2c2b71f15f9955d3
Use #'some, #'every, etc. for composing boolean operations on lists.
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* info.el (Info-insert-dir):
* format.el (format-deannotate-region):
* files.el (cd, save-buffers-kill-emacs):
Use #'some, #'every and related functions for applying boolean
operations to lists, instead of rolling our own ones that cons and
don't short-circuit.
diff -r 90a0084b3541 -r 3acaa0fc09be lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 15:34:35 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 15:58:10 2010 +0100
＠＠ -1,3 +1,12 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * info.el (Info-insert-dir):
+ * format.el (format-deannotate-region):
+ * files.el (cd, save-buffers-kill-emacs):
+ Use #'some, #'every and related functions for applying boolean
+ operations to lists, instead of rolling our own ones that cons and
+ don't short-circuit.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
diff -r 90a0084b3541 -r 3acaa0fc09be lisp/files.el
--- a/lisp/files.el Thu Sep 16 15:34:35 2010 +0100
+++ b/lisp/files.el Thu Sep 16 15:58:10 2010 +0100
＠＠ -606,15 +606,10 ＠＠
(setq cd-path (or (and trypath
(mapcar #'file-name-as-directory trypath))
(list (file-name-as-directory "")))))
- (or (catch 'found
- (mapc #'(lambda (x)
- (let ((f (expand-file-name (concat x dir))))
- (if (file-directory-p f)
- (progn
- (cd-absolute f)
- (throw 'found t)))))
- cd-path)
- nil)
+ (or (some #'(lambda (x)
+ (let ((f (expand-file-name (concat x dir))))
+ (when (file-directory-p f) (cd-absolute f))))
+ cd-path)
;; jwz: give a better error message to those of us with the
;; good taste not to use a kludge like $CDPATH.
(if (equal cd-path '("./"))
＠＠ -4454,9 +4449,10 ＠＠
With prefix arg, silently save all file-visiting buffers, then kill."
(interactive "P")
(save-some-buffers arg t)
- (and (or (not (memq t (mapcar #'(lambda (buf) (and (buffer-file-name buf)
- (buffer-modified-p buf)))
- (buffer-list))))
+ (and (or (not (some #'(lambda (buf)
+ (and (buffer-file-name buf)
+ (buffer-modified-p buf)))
+ (buffer-list)))
(yes-or-no-p "Modified buffers exist; exit anyway? "))
(or (not (fboundp 'process-list))
;; process-list is not defined on VMS.
diff -r 90a0084b3541 -r 3acaa0fc09be lisp/format.el
--- a/lisp/format.el Thu Sep 16 15:34:35 2010 +0100
+++ b/lisp/format.el Thu Sep 16 15:58:10 2010 +0100
＠＠ -604,9 +604,8 ＠＠
(if (member top-name ans)
;; This annotation is listed, but still have to
;; check if multiple annotations are satisfied
- (if (member nil (mapcar (lambda (r)
- (assoc r open-ans))
- ans))
+ (if (notevery (lambda (r) (assoc r open-ans))
+ ans)
nil ; multiple ans not satisfied
;; If there are multiple annotations going
;; into one text property, split up the other
diff -r 90a0084b3541 -r 3acaa0fc09be lisp/info.el
--- a/lisp/info.el Thu Sep 16 15:34:35 2010 +0100
+++ b/lisp/info.el Thu Sep 16 15:58:10 2010 +0100
＠＠ -864,14 +864,13 ＠＠
(if (and Info-dir-contents Info-dir-file-attributes
;; Verify that none of the files we used has changed
;; since we used it.
- (eval (cons 'and
- (mapcar #'(lambda (elt)
- (let ((curr (file-attributes (car elt))))
- ;; Don't compare the access time.
- (if curr (setcar (nthcdr 4 curr) 0))
- (setcar (nthcdr 4 (cdr elt)) 0)
- (equal (cdr elt) curr)))
- Info-dir-file-attributes))))
+ (every #'(lambda (elt)
+ (let ((curr (file-attributes (car elt))))
+ ;; Don't compare the access time.
+ (if curr (setcar (nthcdr 4 curr) 0))
+ (setcar (nthcdr 4 (cdr elt)) 0)
+ (equal (cdr elt) curr)))
+ Info-dir-file-attributes))
(insert Info-dir-contents)
(let ((dirs (reverse Info-directory-list))
buffers lbuffers buffer others nodes dirs-done)
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Use #'some, #'every, etc. for composing boolean operations on lists.
14 years
Aidan Kehoe
Aidan Kehoe
changeset: 5270:3acaa0fc09be
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 15:58:10 2010 +0100
files: lisp/ChangeLog lisp/files.el lisp/format.el lisp/info.el
description:
Use #'some, #'every, etc. for composing boolean operations on lists.
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* info.el (Info-insert-dir):
* format.el (format-deannotate-region):
* files.el (cd, save-buffers-kill-emacs):
Use #'some, #'every and related functions for applying boolean
operations to lists, instead of rolling our own ones that cons and
don't short-circuit.
diff -r 90a0084b3541 -r 3acaa0fc09be lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 15:34:35 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 15:58:10 2010 +0100
＠＠ -1,3 +1,12 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * info.el (Info-insert-dir):
+ * format.el (format-deannotate-region):
+ * files.el (cd, save-buffers-kill-emacs):
+ Use #'some, #'every and related functions for applying boolean
+ operations to lists, instead of rolling our own ones that cons and
+ don't short-circuit.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
diff -r 90a0084b3541 -r 3acaa0fc09be lisp/files.el
--- a/lisp/files.el Thu Sep 16 15:34:35 2010 +0100
+++ b/lisp/files.el Thu Sep 16 15:58:10 2010 +0100
＠＠ -606,15 +606,10 ＠＠
(setq cd-path (or (and trypath
(mapcar #'file-name-as-directory trypath))
(list (file-name-as-directory "")))))
- (or (catch 'found
- (mapc #'(lambda (x)
- (let ((f (expand-file-name (concat x dir))))
- (if (file-directory-p f)
- (progn
- (cd-absolute f)
- (throw 'found t)))))
- cd-path)
- nil)
+ (or (some #'(lambda (x)
+ (let ((f (expand-file-name (concat x dir))))
+ (when (file-directory-p f) (cd-absolute f))))
+ cd-path)
;; jwz: give a better error message to those of us with the
;; good taste not to use a kludge like $CDPATH.
(if (equal cd-path '("./"))
＠＠ -4454,9 +4449,10 ＠＠
With prefix arg, silently save all file-visiting buffers, then kill."
(interactive "P")
(save-some-buffers arg t)
- (and (or (not (memq t (mapcar #'(lambda (buf) (and (buffer-file-name buf)
- (buffer-modified-p buf)))
- (buffer-list))))
+ (and (or (not (some #'(lambda (buf)
+ (and (buffer-file-name buf)
+ (buffer-modified-p buf)))
+ (buffer-list)))
(yes-or-no-p "Modified buffers exist; exit anyway? "))
(or (not (fboundp 'process-list))
;; process-list is not defined on VMS.
diff -r 90a0084b3541 -r 3acaa0fc09be lisp/format.el
--- a/lisp/format.el Thu Sep 16 15:34:35 2010 +0100
+++ b/lisp/format.el Thu Sep 16 15:58:10 2010 +0100
＠＠ -604,9 +604,8 ＠＠
(if (member top-name ans)
;; This annotation is listed, but still have to
;; check if multiple annotations are satisfied
- (if (member nil (mapcar (lambda (r)
- (assoc r open-ans))
- ans))
+ (if (notevery (lambda (r) (assoc r open-ans))
+ ans)
nil ; multiple ans not satisfied
;; If there are multiple annotations going
;; into one text property, split up the other
diff -r 90a0084b3541 -r 3acaa0fc09be lisp/info.el
--- a/lisp/info.el Thu Sep 16 15:34:35 2010 +0100
+++ b/lisp/info.el Thu Sep 16 15:58:10 2010 +0100
＠＠ -864,14 +864,13 ＠＠
(if (and Info-dir-contents Info-dir-file-attributes
;; Verify that none of the files we used has changed
;; since we used it.
- (eval (cons 'and
- (mapcar #'(lambda (elt)
- (let ((curr (file-attributes (car elt))))
- ;; Don't compare the access time.
- (if curr (setcar (nthcdr 4 curr) 0))
- (setcar (nthcdr 4 (cdr elt)) 0)
- (equal (cdr elt) curr)))
- Info-dir-file-attributes))))
+ (every #'(lambda (elt)
+ (let ((curr (file-attributes (car elt))))
+ ;; Don't compare the access time.
+ (if curr (setcar (nthcdr 4 curr) 0))
+ (setcar (nthcdr 4 (cdr elt)) 0)
+ (equal (cdr elt) curr)))
+ Info-dir-file-attributes))
(insert Info-dir-contents)
(let ((dirs (reverse Info-directory-list))
buffers lbuffers buffer others nodes dirs-done)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Rephrase the #'the docstring, make it nicer while byte-compiling.
14 years
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1284647675 -3600
# Node ID 90a0084b3541132a577136fc2c2b71f15f9955d3
# Parent 09f8ed0933c7d237cf1c42ac25a60b188a0ab222
Rephrase the #'the docstring, make it nicer while byte-compiling.
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
* cl-macs.el (the):
Rephrase the docstring, make its implementation when compiling
files a little nicer.
diff -r 09f8ed0933c7 -r 90a0084b3541 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 15:24:40 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 15:34:35 2010 +0100
＠＠ -1,3 +1,10 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * bytecomp.el (byte-compile-initial-macro-environment):
+ * cl-macs.el (the):
+ Rephrase the docstring, make its implementation when compiling
+ files a little nicer.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* descr-text.el (unidata-initialize-unicodedata-database)
diff -r 09f8ed0933c7 -r 90a0084b3541 lisp/bytecomp.el
--- a/lisp/bytecomp.el Thu Sep 16 15:24:40 2010 +0100
+++ b/lisp/bytecomp.el Thu Sep 16 15:34:35 2010 +0100
＠＠ -504,10 +504,10 ＠＠
(byte-compile-eval (cons 'progn body))
(cons 'progn body)))
(the .
- ,#'(lambda (&rest body)
+ ,#'(lambda (type form)
(if byte-compile-delete-errors
- (second body)
- (apply (cdr (symbol-function 'the)) body)))))
+ form
+ (funcall (cdr (symbol-function 'the)) type form)))))
"The default macro-environment passed to macroexpand by the compiler.
Placing a macro here will cause a macro to have different semantics when
expanded by the compiler as when expanded by the interpreter.")
diff -r 09f8ed0933c7 -r 90a0084b3541 lisp/cl-macs.el
--- a/lisp/cl-macs.el Thu Sep 16 15:24:40 2010 +0100
+++ b/lisp/cl-macs.el Thu Sep 16 15:34:35 2010 +0100
＠＠ -1963,13 +1963,13 ＠＠
(defmacro locally (&rest body) (cons 'progn body))
;;;###autoload
(defmacro the (type form)
- "Assert that FORM gives a result of type TYPE, and return FORM.
+ "Assert that FORM gives a result of type TYPE, and return that result.
TYPE is a Common Lisp type specifier.
If macro expansion of a `the' form happens during byte compilation, and the
byte compiler customization variable `byte-compile-delete-errors' is
-non-nil, `the' just returns FORM, without making any type checks."
+non-nil, `the' is equivalent to FORM without any type checks."
(if (cl-safe-expr-p form)
`(prog1 ,form (assert ,(cl-make-type-test form type) t))
(let ((saved (gensym)))
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Rephrase the #'the docstring, make it nicer while byte-compiling.
14 years
Aidan Kehoe
Aidan Kehoe
changeset: 5269:90a0084b3541
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 15:34:35 2010 +0100
files: lisp/ChangeLog lisp/bytecomp.el lisp/cl-macs.el
description:
Rephrase the #'the docstring, make it nicer while byte-compiling.
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
* cl-macs.el (the):
Rephrase the docstring, make its implementation when compiling
files a little nicer.
diff -r 09f8ed0933c7 -r 90a0084b3541 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 15:24:40 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 15:34:35 2010 +0100
＠＠ -1,3 +1,10 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * bytecomp.el (byte-compile-initial-macro-environment):
+ * cl-macs.el (the):
+ Rephrase the docstring, make its implementation when compiling
+ files a little nicer.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* descr-text.el (unidata-initialize-unicodedata-database)
diff -r 09f8ed0933c7 -r 90a0084b3541 lisp/bytecomp.el
--- a/lisp/bytecomp.el Thu Sep 16 15:24:40 2010 +0100
+++ b/lisp/bytecomp.el Thu Sep 16 15:34:35 2010 +0100
＠＠ -504,10 +504,10 ＠＠
(byte-compile-eval (cons 'progn body))
(cons 'progn body)))
(the .
- ,#'(lambda (&rest body)
+ ,#'(lambda (type form)
(if byte-compile-delete-errors
- (second body)
- (apply (cdr (symbol-function 'the)) body)))))
+ form
+ (funcall (cdr (symbol-function 'the)) type form)))))
"The default macro-environment passed to macroexpand by the compiler.
Placing a macro here will cause a macro to have different semantics when
expanded by the compiler as when expanded by the interpreter.")
diff -r 09f8ed0933c7 -r 90a0084b3541 lisp/cl-macs.el
--- a/lisp/cl-macs.el Thu Sep 16 15:24:40 2010 +0100
+++ b/lisp/cl-macs.el Thu Sep 16 15:34:35 2010 +0100
＠＠ -1963,13 +1963,13 ＠＠
(defmacro locally (&rest body) (cons 'progn body))
;;;###autoload
(defmacro the (type form)
- "Assert that FORM gives a result of type TYPE, and return FORM.
+ "Assert that FORM gives a result of type TYPE, and return that result.
TYPE is a Common Lisp type specifier.
If macro expansion of a `the' form happens during byte compilation, and the
byte compiler customization variable `byte-compile-delete-errors' is
-non-nil, `the' just returns FORM, without making any type checks."
+non-nil, `the' is equivalent to FORM without any type checks."
(if (cl-safe-expr-p form)
`(prog1 ,form (assert ,(cl-make-type-test form type) t))
(let ((saved (gensym)))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Avoid byte compiler warnings, some needless consing, descr-text.el
14 years
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1284647080 -3600
# Node ID 09f8ed0933c7d237cf1c42ac25a60b188a0ab222
# Parent 668c73e222fd7178d342124bc1f02c316855ec0e
Avoid byte compiler warnings, some needless consing, descr-text.el
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* descr-text.el (unidata-initialize-unicodedata-database)
(unidata-initialize-unihan-database, describe-char-unicode-data)
(describe-char-unicode-data):
Wrap calls to the database functions with (with-fboundp ...),
avoiding byte compile warnings on builds without support for the
database functions.
(describe-char): (reduce #'max ...), not (apply #'max ...), no
need to cons needlessly.
(describe-char): Remove a redundant lambda wrapping
#'extent-properties.
(describe-char-unicode-data): Call #'nsubst when replacing "" with
nil in the result of #'split-string, instead of consing inside
mapcar.
diff -r 668c73e222fd -r 09f8ed0933c7 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 15:06:38 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 15:24:40 2010 +0100
＠＠ -1,3 +1,19 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * descr-text.el (unidata-initialize-unicodedata-database)
+ (unidata-initialize-unihan-database, describe-char-unicode-data)
+ (describe-char-unicode-data):
+ Wrap calls to the database functions with (with-fboundp ...),
+ avoiding byte compile warnings on builds without support for the
+ database functions.
+ (describe-char): (reduce #'max ...), not (apply #'max ...), no
+ need to cons needlessly.
+ (describe-char): Remove a redundant lambda wrapping
+ #'extent-properties.
+ (describe-char-unicode-data): Call #'nsubst when replacing "" with
+ nil in the result of #'split-string, instead of consing inside
+ mapcar.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* x-faces.el (x-available-font-sizes):
diff -r 668c73e222fd -r 09f8ed0933c7 lisp/descr-text.el
--- a/lisp/descr-text.el Thu Sep 16 15:06:38 2010 +0100
+++ b/lisp/descr-text.el Thu Sep 16 15:24:40 2010 +0100
＠＠ -457,98 +457,100 ＠＠
(check-argument-type #'file-readable-p unidata-file-name)
(unless unidata-database-format
(error 'unimplemented "No (non-SQL) DB support available"))
- (let* ((database-format unidata-database-format)
- (size (eighth (file-attributes unidata-file-name)))
- (database-file-name
- (unidata-generate-database-file-name unidata-file-name
- size database-format))
- (database-handle (open-database database-file-name database-format
- nil "rw+" #o644 'no-conversion-unix))
- (coding-system-for-read 'no-conversion-unix)
- (buffer-size 32768)
- (offset-start 0)
- (offset-end buffer-size)
- (range-information (make-range-table 'start-closed-end-closed))
- (range-staging (make-hash-table :test 'equal))
- (message "Initializing UnicodeData database cache: ")
- (loop-count 1)
- range-startinfo)
- (with-temp-buffer
+ (with-fboundp '(open-database put-database close-database)
+ (let* ((database-format unidata-database-format)
+ (size (eighth (file-attributes unidata-file-name)))
+ (database-file-name
+ (unidata-generate-database-file-name unidata-file-name
+ size database-format))
+ (database-handle (open-database database-file-name database-format
+ nil "rw+" #o644
+ 'no-conversion-unix))
+ (coding-system-for-read 'no-conversion-unix)
+ (buffer-size 32768)
+ (offset-start 0)
+ (offset-end buffer-size)
+ (range-information (make-range-table 'start-closed-end-closed))
+ (range-staging (make-hash-table :test 'equal))
+ (message "Initializing UnicodeData database cache: ")
+ (loop-count 1)
+ range-startinfo)
+ (with-temp-buffer
+ (progress-feedback-with-label 'describe-char-unicodedata-file
+ "%s" 0 message)
+ (while (progn
+ (delete-region (point-min) (point-max))
+ (insert-file-contents unidata-file-name nil
+ offset-start offset-end)
+ ;; If we've reached the end of the data, pass nil back to
+ ;; the while loop test.
+ (not (= (point-min) (point-max))))
+
+ (when (= buffer-size (- (point-max) (point-min)))
+ ;; If we're in the body of the file, and there's a trailing
+ ;; incomplete end-line, delete it, and adjust offset-end
+ ;; appropriately.
+ (goto-char (point-max))
+ (search-backward "\n")
+ (forward-char)
+ (delete-region (point) (point-max))
+ (setq offset-end (+ offset-start (- (point) (point-min)))))
+
+ (progress-feedback-with-label 'describe-char-unicodedata-file
+ "%s" (truncate
+ (* (/ offset-start size) 100))
+ (concat message
+ (make-string
+ (mod loop-count 39) ?.)))
+ (incf loop-count)
+ (goto-char (point-min))
+ (while (re-search-forward
+ #r"^\([0-9A-F]\{4,6\}\);\([^;]*\);.*$" nil t)
+ (cond
+ ((and (> (- (match-end 2) (match-beginning 2)) 7)
+ (equal (substring (match-string 2) -7)
+ " First>"))
+ ;; Start of a range. Save the start info in range-staging.
+ (puthash (substring (match-string 2) 0 -7)
+ (list (string-to-int (match-string 1) 16)
+ (+ offset-start (1- (match-beginning 0))))
+ range-staging))
+ ((and (> (- (match-end 2) (match-beginning 2)) 7)
+ (equal (substring (match-string 2) -6)
+ " Last>"))
+ ;; End of a range. Combine with the start info, save it to the
+ ;; range-information range table.
+ (setq range-startinfo
+ (gethash (substring (match-string 2) 0 -6) range-staging))
+ (assert range-startinfo nil
+ "Unexpected order for range information.")
+ (put-range-table
+ (first range-startinfo)
+ (string-to-int (match-string 1) 16)
+ (list (second range-startinfo)
+ (+ offset-start (1- (match-end 0))))
+ range-information)
+ (remhash (substring (match-string 2) 0 -6) range-staging))
+ (t
+ ;; Normal character. Save the associated information in the
+ ;; database directly.
+ (put-database (match-string 1)
+ (format "(%d %d)"
+ (+ offset-start (1- (match-beginning 0)))
+ (+ offset-start (1- (match-end 0))))
+ database-handle))))
+ (goto-char (point-min))
+ (setq offset-start offset-end
+ offset-end (+ buffer-size offset-end))))
+ ;; Save the range information as such in the database.
+ (put-database "range-information"
+ (let ((print-readably t))
+ (prin1-to-string range-information))
+ database-handle)
+ (close-database database-handle)
(progress-feedback-with-label 'describe-char-unicodedata-file
- "%s" 0 message)
- (while (progn
- (delete-region (point-min) (point-max))
- (insert-file-contents unidata-file-name nil
- offset-start offset-end)
- ;; If we've reached the end of the data, pass nil back to
- ;; the while loop test.
- (not (= (point-min) (point-max))))
-
- (when (= buffer-size (- (point-max) (point-min)))
- ;; If we're in the body of the file, and there's a trailing
- ;; incomplete end-line, delete it, and adjust offset-end
- ;; appropriately.
- (goto-char (point-max))
- (search-backward "\n")
- (forward-char)
- (delete-region (point) (point-max))
- (setq offset-end (+ offset-start (- (point) (point-min)))))
-
- (progress-feedback-with-label 'describe-char-unicodedata-file
- "%s" (truncate
- (* (/ offset-start size) 100))
- (concat message
- (make-string
- (mod loop-count 39) ?.)))
- (incf loop-count)
- (goto-char (point-min))
- (while (re-search-forward
- #r"^\([0-9A-F]\{4,6\}\);\([^;]*\);.*$" nil t)
- (cond
- ((and (> (- (match-end 2) (match-beginning 2)) 7)
- (equal (substring (match-string 2) -7)
- " First>"))
- ;; Start of a range. Save the start info in range-staging.
- (puthash (substring (match-string 2) 0 -7)
- (list (string-to-int (match-string 1) 16)
- (+ offset-start (1- (match-beginning 0))))
- range-staging))
- ((and (> (- (match-end 2) (match-beginning 2)) 7)
- (equal (substring (match-string 2) -6)
- " Last>"))
- ;; End of a range. Combine with the start info, save it to the
- ;; range-information range table.
- (setq range-startinfo
- (gethash (substring (match-string 2) 0 -6) range-staging))
- (assert range-startinfo nil
- "Unexpected order for range information.")
- (put-range-table
- (first range-startinfo)
- (string-to-int (match-string 1) 16)
- (list (second range-startinfo)
- (+ offset-start (1- (match-end 0))))
- range-information)
- (remhash (substring (match-string 2) 0 -6) range-staging))
- (t
- ;; Normal character. Save the associated information in the
- ;; database directly.
- (put-database (match-string 1)
- (format "(%d %d)"
- (+ offset-start (1- (match-beginning 0)))
- (+ offset-start (1- (match-end 0))))
- database-handle))))
- (goto-char (point-min))
- (setq offset-start offset-end
- offset-end (+ buffer-size offset-end))))
- ;; Save the range information as such in the database.
- (put-database "range-information"
- (let ((print-readably t))
- (prin1-to-string range-information))
- database-handle)
- (close-database database-handle)
- (progress-feedback-with-label 'describe-char-unicodedata-file
- "%s" 100 message)
- database-file-name))
+ "%s" 100 message)
+ database-file-name)))
(defun unidata-initialize-unihan-database (unihan-file-name)
"Init the berkeley or gdbm lookup table for UNIHAN-FILE-NAME.
＠＠ -562,114 +564,115 ＠＠
(check-argument-type #'file-readable-p unihan-file-name)
(unless unidata-database-format
(error 'unimplemented "No (non-SQL) DB support available"))
- (let* ((database-format unidata-database-format)
- (size (eighth (file-attributes unihan-file-name)))
- (database-file-name
- (unidata-generate-database-file-name unihan-file-name
- size database-format))
- (database-handle (open-database database-file-name database-format
- nil "rw+" #o644 'no-conversion-unix))
- (coding-system-for-read 'no-conversion-unix)
- (buffer-size 65536)
- (offset-start 0)
- (offset-end buffer-size)
- (message "Initializing Unihan database cache: ")
- (loop-count 1)
- trailing-unicode leading-unicode character-start character-end)
- (with-temp-buffer
+ (with-fboundp '(open-database put-database close-database)
+ (let* ((database-format unidata-database-format)
+ (size (eighth (file-attributes unihan-file-name)))
+ (database-file-name
+ (unidata-generate-database-file-name unihan-file-name
+ size database-format))
+ (database-handle (open-database database-file-name database-format
+ nil "rw+" #o644
+ 'no-conversion-unix))
+ (coding-system-for-read 'no-conversion-unix)
+ (buffer-size 65536)
+ (offset-start 0)
+ (offset-end buffer-size)
+ (message "Initializing Unihan database cache: ")
+ (loop-count 1)
+ trailing-unicode leading-unicode character-start character-end)
+ (with-temp-buffer
+ (progress-feedback-with-label 'describe-char-unihan-file
+ "%s" 0 message)
+ (while (progn
+ (delete-region (point-min) (point-max))
+ (insert-file-contents unihan-file-name nil
+ offset-start offset-end)
+ ;; If we've reached the end of the data, return nil to the
+ ;; while.
+ (not (= (point-min) (point-max))))
+
+ (incf loop-count)
+ (progress-feedback-with-label 'describe-char-unihan-file
+ "%s" (truncate
+ (* (/ offset-start size) 100))
+ (concat message
+ (make-string
+ (mod loop-count 44) ?.)))
+ (block 'dealing-with-chars
+ (when (= buffer-size (- (point-max) (point-min)))
+ ;; If we're in the body of the file, we need to delete the
+ ;; character info for the last character, and set offset-end
+ ;; appropriately. Otherwise, we may not be able to pick where
+ ;; the actual description of a character ends and begins.
+ ;;
+ ;; This breaks if any single Unihan character description is
+ ;; greater than the buffer size in length.
+ (goto-char (point-max))
+ (beginning-of-line)
+
+ (when (< (- (point-max) (point)) (eval-when-compile
+ (length "U+ABCDEF\t")))
+ ;; If the character ID of the last line may have been cut off,
+ ;; we need to delete all of that line here.
+ (delete-region (point) (point-max))
+ (forward-line -1))
+
+ (when (looking-at "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t")
+ (setq trailing-unicode (match-string 1)
+ trailing-unicode
+ (format "^%s\t" (regexp-quote trailing-unicode)))
+
+ (end-of-line)
+
+ ;; Go back until we hit a line that doesn't start with this
+ ;; character info.
+ (while (re-search-backward trailing-unicode nil t))
+
+ ;; The re-search-backward failed, so point is still at the end
+ ;; of the last match. Move to its beginning.
+ (beginning-of-line)
+ (delete-region (point) (point-max))
+ (setq offset-end (+ offset-start (- (point) (point-min))))))
+ (goto-char (point-min))
+ (while t
+ (when (= (point) (point-max))
+ ;; We're at the end of this part of the file.
+ (return-from 'dealing-with-chars))
+
+ (unless (re-search-forward "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t"
+ nil t)
+ ;; We're probably in the comments at the start of the
+ ;; file. No need to look for character info.
+ (return-from 'dealing-with-chars))
+
+ ;; Store where the character started.
+ (beginning-of-line)
+ (setq character-start (point))
+
+ (setq leading-unicode
+ (format "^%s\t" (regexp-quote (match-string 1))))
+
+ ;; Loop until we get past this entry.
+ (while (re-search-forward leading-unicode nil t))
+
+ ;; Now, store the information.
+ (setq leading-unicode
+ (string-to-number (substring leading-unicode 3) 16)
+ leading-unicode (format "%04X" leading-unicode)
+ character-end (prog2 (end-of-line) (point)))
+ (put-database leading-unicode
+ (format "(%d %d)"
+ (+ offset-start (1- character-start))
+ (+ offset-start (1- character-end)))
+ database-handle)
+ (forward-line)))
+ (setq offset-start offset-end
+ offset-end (+ buffer-size offset-end))))
+ (close-database database-handle)
(progress-feedback-with-label 'describe-char-unihan-file
- "%s" 0 message)
- (while (progn
- (delete-region (point-min) (point-max))
- (insert-file-contents unihan-file-name nil
- offset-start offset-end)
- ;; If we've reached the end of the data, return nil to the
- ;; while.
- (not (= (point-min) (point-max))))
-
- (incf loop-count)
- (progress-feedback-with-label 'describe-char-unihan-file
- "%s" (truncate
- (* (/ offset-start size) 100))
- (concat message
- (make-string
- (mod loop-count 44) ?.)))
- (block 'dealing-with-chars
- (when (= buffer-size (- (point-max) (point-min)))
- ;; If we're in the body of the file, we need to delete the
- ;; character info for the last character, and set offset-end
- ;; appropriately. Otherwise, we may not be able to pick where
- ;; the actual description of a character ends and
- ;; begins.
- ;;
- ;; This breaks if any single Unihan character description is
- ;; greater than the buffer size in length.
- (goto-char (point-max))
- (beginning-of-line)
-
- (when (< (- (point-max) (point)) (eval-when-compile
- (length "U+ABCDEF\t")))
- ;; If the character ID of the last line may have been cut off,
- ;; we need to delete all of that line here.
- (delete-region (point) (point-max))
- (forward-line -1))
-
- (when (looking-at "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t")
- (setq trailing-unicode (match-string 1)
- trailing-unicode
- (format "^%s\t" (regexp-quote trailing-unicode)))
-
- (end-of-line)
-
- ;; Go back until we hit a line that doesn't start with this
- ;; character info.
- (while (re-search-backward trailing-unicode nil t))
-
- ;; The re-search-backward failed, so point is still at the end
- ;; of the last match. Move to its beginning.
- (beginning-of-line)
- (delete-region (point) (point-max))
- (setq offset-end (+ offset-start (- (point) (point-min))))))
- (goto-char (point-min))
- (while t
- (when (= (point) (point-max))
- ;; We're at the end of this part of the file.
- (return-from 'dealing-with-chars))
-
- (unless (re-search-forward "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t"
- nil t)
- ;; We're probably in the comments at the start of the file. No
- ;; need to look for character info.
- (return-from 'dealing-with-chars))
-
- ;; Store where the character started.
- (beginning-of-line)
- (setq character-start (point))
-
- (setq leading-unicode
- (format "^%s\t" (regexp-quote (match-string 1))))
-
- ;; Loop until we get past this entry.
- (while (re-search-forward leading-unicode nil t))
-
- ;; Now, store the information.
- (setq leading-unicode
- (string-to-number (substring leading-unicode 3) 16)
- leading-unicode (format "%04X" leading-unicode)
- character-end (prog2 (end-of-line) (point)))
- (put-database leading-unicode
- (format "(%d %d)"
- (+ offset-start (1- character-start))
- (+ offset-start (1- character-end)))
- database-handle)
- (forward-line)))
- (setq offset-start offset-end
- offset-end (+ buffer-size offset-end))))
- (close-database database-handle)
- (progress-feedback-with-label 'describe-char-unihan-file
- "%s" 100
- message)
- database-file-name))
+ "%s" 100
+ message)
+ database-file-name)))
;; End XEmacs additions.
(defun describe-char-unicode-data (char)
＠＠ -688,52 +691,55 ＠＠
(with-temp-buffer
(let ((coding-system-for-read coding-system-for-read)
database-handle key lookup)
- (if (and describe-char-use-cache
- (prog1
- (setq database-handle
- (open-database
- (unidata-generate-database-file-name
- describe-char-unicodedata-file
- (eighth (file-attributes
- describe-char-unicodedata-file))
- unidata-database-format)
- unidata-database-format
- nil "r"
- #o644 'no-conversion-unix))
- (unless database-handle
- (warn "Could not open %s as a %s database"
- (unidata-generate-database-file-name
- describe-char-unicodedata-file
- (eighth (file-attributes
- describe-char-unicodedata-file))
- unidata-database-format)
- unidata-database-format))))
- (progn
- ;; Use the database info.
- (setq coding-system-for-read 'no-conversion-unix
- key (format "%04X" char)
- lookup (get-database key database-handle))
- (if lookup
- ;; Okay, we have information on that character in particular.
- (progn (setq lookup (read lookup))
- (insert-file-contents describe-char-unicodedata-file
- nil (first lookup)
- (second lookup)))
- ;; No information on that character in particular. Do we
- ;; have range information? If so, load and check for our
- ;; desired character.
- (setq lookup (get-database "range-information" database-handle)
- lookup (if lookup (read lookup))
- lookup (if lookup (get-range-table char lookup)))
- (when lookup
- (insert-file-contents describe-char-unicodedata-file nil
- (first lookup) (second lookup))))
- (close-database database-handle))
- ;; Otherwise, insert the whole file (the FSF approach).
- (set-buffer (get-buffer-create " *Unicode Data*"))
- (when (zerop (buffer-size))
- ;; Don't use -literally in case of DOS line endings.
- (insert-file-contents describe-char-unicodedata-file))))
+ (with-fboundp '(open-database get-database close-database)
+ (if (and describe-char-use-cache
+ (prog1
+ (setq database-handle
+ (open-database
+ (unidata-generate-database-file-name
+ describe-char-unicodedata-file
+ (eighth (file-attributes
+ describe-char-unicodedata-file))
+ unidata-database-format)
+ unidata-database-format
+ nil "r"
+ #o644 'no-conversion-unix))
+ (unless database-handle
+ (warn "Could not open %s as a %s database"
+ (unidata-generate-database-file-name
+ describe-char-unicodedata-file
+ (eighth (file-attributes
+ describe-char-unicodedata-file))
+ unidata-database-format)
+ unidata-database-format))))
+ (progn
+ ;; Use the database info.
+ (setq coding-system-for-read 'no-conversion-unix
+ key (format "%04X" char)
+ lookup (get-database key database-handle))
+ (if lookup
+ ;; Okay, we have information on that character in
+ ;; particular.
+ (progn (setq lookup (read lookup))
+ (insert-file-contents describe-char-unicodedata-file
+ nil (first lookup)
+ (second lookup)))
+ ;; No information on that character in particular. Do we
+ ;; have range information? If so, load and check for our
+ ;; desired character.
+ (setq lookup (get-database "range-information"
+ database-handle)
+ lookup (if lookup (read lookup))
+ lookup (if lookup (get-range-table char lookup)))
+ (when lookup
+ (insert-file-contents describe-char-unicodedata-file nil
+ (first lookup) (second lookup))))
+ (close-database database-handle))
+ ;; Otherwise, insert the whole file (the FSF approach).
+ (set-buffer (get-buffer-create " *Unicode Data*"))
+ (when (zerop (buffer-size))
+ ;; Don't use -literally in case of DOS line endings.
+ (insert-file-contents describe-char-unicodedata-file)))))
(goto-char (point-min))
(let ((hex (format "%04X" char))
found first last unihan-match unihan-info unihan-database-handle
＠＠ -755,14 +761,11 ＠＠
last (<= char last))
(setq found t)))
(if found
- (let ((fields (mapcar (lambda (elt)
- (if (> (length elt) 0)
- elt))
- (cdr (split-string
- (buffer-substring
- (line-beginning-position)
- (line-end-position))
- ";")))))
+ (let ((fields (cdr (nsubst nil "" (split-string
+ (buffer-substring
+ (line-beginning-position)
+ (line-end-position)) ";")
+ :test 'equal))))
;; The length depends on whether the last field was empty.
(unless (or (= 13 (length fields))
(= 14 (length fields)))
＠＠ -919,45 +922,46 ＠＠
(if (and (> (length (nth 0 fields)) 13)
(equal "<CJK Ideograph"
(substring (nth 0 fields) 0 14)))
- (if (and describe-char-unihan-file
- (setq unihan-database-handle
- (open-database
- (unidata-generate-database-file-name
- describe-char-unihan-file
- (eighth (file-attributes
- describe-char-unihan-file))
- unidata-database-format)
- unidata-database-format
- nil "r" #o644 'no-conversion-unix))
- (setq unihan-match
- (get-database (format "%04X" char)
- unihan-database-handle)
- unihan-match
- (and unihan-match (read unihan-match))))
- (with-temp-buffer
- (insert-file-contents describe-char-unihan-file
- nil (first unihan-match)
- (second unihan-match))
- (goto-char (point-min))
- (while (re-search-forward
- "^U\\+[0-9A-F]+\t\\(k[^\t]+\\)\t\\(.*\\)$"
- nil t)
- (push
- (list
- (or (gethash
- (match-string 1)
- describe-char-unihan-field-descriptions)
- (match-string 1))
- (decode-coding-string (match-string 2) 'utf-8))
- unihan-info))
- (close-database unihan-database-handle)
- unihan-info)
+ (with-fboundp '(open-database get-database close-database)
+ (if (and describe-char-unihan-file
+ (setq unihan-database-handle
+ (open-database
+ (unidata-generate-database-file-name
+ describe-char-unihan-file
+ (eighth (file-attributes
+ describe-char-unihan-file))
+ unidata-database-format)
+ unidata-database-format
+ nil "r" #o644 'no-conversion-unix))
+ (setq unihan-match
+ (get-database (format "%04X" char)
+ unihan-database-handle)
+ unihan-match
+ (and unihan-match (read unihan-match))))
+ (with-temp-buffer
+ (insert-file-contents describe-char-unihan-file
+ nil (first unihan-match)
+ (second unihan-match))
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^U\\+[0-9A-F]+\t\\(k[^\t]+\\)\t\\(.*\\)$"
+ nil t)
+ (push
+ (list
+ (or (gethash
+ (match-string 1)
+ describe-char-unihan-field-descriptions)
+ (match-string 1))
+ (decode-coding-string (match-string 2) 'utf-8))
+ unihan-info))
+ (close-database unihan-database-handle)
+ unihan-info)
;; It's a Han character, but Unihan.txt is not
;; available. Tell the user.
(list
'("Unihan"
"No Unihan information available; is \
-`describe-char-unihan-file' set, and its cache initialized?")))))))))))
+`describe-char-unihan-file' set, and its cache initialized?"))))))))))))
;; Return information about how CHAR is displayed at the buffer
;; position POS. If the selected frame is on a graphic display,
＠＠ -1030,8 +1034,7 ＠＠
(specifier-instance current-display-table (selected-window)))
(disp-table-entry (and display-table
(get-display-table char display-table)))
- (extents (mapcar #'(lambda (o) (extent-properties o))
- (extents-at pos)))
+ (extents (mapcar #'extent-properties (extents-at pos)))
(char-description (single-key-description char))
(text-props-desc
(let ((tmp-buf (generate-new-buffer " *text-props*")))
＠＠ -1202,9 +1205,9 ＠＠
(describe-char-unicode-data unicode)))
(if unicodedata
(cons (list "Unicode data" " ") unicodedata)))))
- (setq max-width (apply #'max (mapcar #'(lambda (x)
- (if (cadr x) (length (car x)) 0))
- item-list)))
+ (setq max-width
+ (reduce #'max (remove-if-not #'cadr item-list) :initial-value 0
+:key #'(lambda (object) (length (car object)))))
(when (and unicodedata (> max-width max-unicode-description-width))
(setq max-width max-unicode-description-width)
(with-temp-buffer
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Avoid byte compiler warnings, some needless consing, descr-text.el
14 years
Aidan Kehoe
Aidan Kehoe
changeset: 5268:09f8ed0933c7
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 15:24:40 2010 +0100
files: lisp/ChangeLog lisp/descr-text.el
description:
Avoid byte compiler warnings, some needless consing, descr-text.el
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* descr-text.el (unidata-initialize-unicodedata-database)
(unidata-initialize-unihan-database, describe-char-unicode-data)
(describe-char-unicode-data):
Wrap calls to the database functions with (with-fboundp ...),
avoiding byte compile warnings on builds without support for the
database functions.
(describe-char): (reduce #'max ...), not (apply #'max ...), no
need to cons needlessly.
(describe-char): Remove a redundant lambda wrapping
#'extent-properties.
(describe-char-unicode-data): Call #'nsubst when replacing "" with
nil in the result of #'split-string, instead of consing inside
mapcar.
diff -r 668c73e222fd -r 09f8ed0933c7 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 15:06:38 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 15:24:40 2010 +0100
＠＠ -1,3 +1,19 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * descr-text.el (unidata-initialize-unicodedata-database)
+ (unidata-initialize-unihan-database, describe-char-unicode-data)
+ (describe-char-unicode-data):
+ Wrap calls to the database functions with (with-fboundp ...),
+ avoiding byte compile warnings on builds without support for the
+ database functions.
+ (describe-char): (reduce #'max ...), not (apply #'max ...), no
+ need to cons needlessly.
+ (describe-char): Remove a redundant lambda wrapping
+ #'extent-properties.
+ (describe-char-unicode-data): Call #'nsubst when replacing "" with
+ nil in the result of #'split-string, instead of consing inside
+ mapcar.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* x-faces.el (x-available-font-sizes):
diff -r 668c73e222fd -r 09f8ed0933c7 lisp/descr-text.el
--- a/lisp/descr-text.el Thu Sep 16 15:06:38 2010 +0100
+++ b/lisp/descr-text.el Thu Sep 16 15:24:40 2010 +0100
＠＠ -457,98 +457,100 ＠＠
(check-argument-type #'file-readable-p unidata-file-name)
(unless unidata-database-format
(error 'unimplemented "No (non-SQL) DB support available"))
- (let* ((database-format unidata-database-format)
- (size (eighth (file-attributes unidata-file-name)))
- (database-file-name
- (unidata-generate-database-file-name unidata-file-name
- size database-format))
- (database-handle (open-database database-file-name database-format
- nil "rw+" #o644 'no-conversion-unix))
- (coding-system-for-read 'no-conversion-unix)
- (buffer-size 32768)
- (offset-start 0)
- (offset-end buffer-size)
- (range-information (make-range-table 'start-closed-end-closed))
- (range-staging (make-hash-table :test 'equal))
- (message "Initializing UnicodeData database cache: ")
- (loop-count 1)
- range-startinfo)
- (with-temp-buffer
+ (with-fboundp '(open-database put-database close-database)
+ (let* ((database-format unidata-database-format)
+ (size (eighth (file-attributes unidata-file-name)))
+ (database-file-name
+ (unidata-generate-database-file-name unidata-file-name
+ size database-format))
+ (database-handle (open-database database-file-name database-format
+ nil "rw+" #o644
+ 'no-conversion-unix))
+ (coding-system-for-read 'no-conversion-unix)
+ (buffer-size 32768)
+ (offset-start 0)
+ (offset-end buffer-size)
+ (range-information (make-range-table 'start-closed-end-closed))
+ (range-staging (make-hash-table :test 'equal))
+ (message "Initializing UnicodeData database cache: ")
+ (loop-count 1)
+ range-startinfo)
+ (with-temp-buffer
+ (progress-feedback-with-label 'describe-char-unicodedata-file
+ "%s" 0 message)
+ (while (progn
+ (delete-region (point-min) (point-max))
+ (insert-file-contents unidata-file-name nil
+ offset-start offset-end)
+ ;; If we've reached the end of the data, pass nil back to
+ ;; the while loop test.
+ (not (= (point-min) (point-max))))
+
+ (when (= buffer-size (- (point-max) (point-min)))
+ ;; If we're in the body of the file, and there's a trailing
+ ;; incomplete end-line, delete it, and adjust offset-end
+ ;; appropriately.
+ (goto-char (point-max))
+ (search-backward "\n")
+ (forward-char)
+ (delete-region (point) (point-max))
+ (setq offset-end (+ offset-start (- (point) (point-min)))))
+
+ (progress-feedback-with-label 'describe-char-unicodedata-file
+ "%s" (truncate
+ (* (/ offset-start size) 100))
+ (concat message
+ (make-string
+ (mod loop-count 39) ?.)))
+ (incf loop-count)
+ (goto-char (point-min))
+ (while (re-search-forward
+ #r"^\([0-9A-F]\{4,6\}\);\([^;]*\);.*$" nil t)
+ (cond
+ ((and (> (- (match-end 2) (match-beginning 2)) 7)
+ (equal (substring (match-string 2) -7)
+ " First>"))
+ ;; Start of a range. Save the start info in range-staging.
+ (puthash (substring (match-string 2) 0 -7)
+ (list (string-to-int (match-string 1) 16)
+ (+ offset-start (1- (match-beginning 0))))
+ range-staging))
+ ((and (> (- (match-end 2) (match-beginning 2)) 7)
+ (equal (substring (match-string 2) -6)
+ " Last>"))
+ ;; End of a range. Combine with the start info, save it to the
+ ;; range-information range table.
+ (setq range-startinfo
+ (gethash (substring (match-string 2) 0 -6) range-staging))
+ (assert range-startinfo nil
+ "Unexpected order for range information.")
+ (put-range-table
+ (first range-startinfo)
+ (string-to-int (match-string 1) 16)
+ (list (second range-startinfo)
+ (+ offset-start (1- (match-end 0))))
+ range-information)
+ (remhash (substring (match-string 2) 0 -6) range-staging))
+ (t
+ ;; Normal character. Save the associated information in the
+ ;; database directly.
+ (put-database (match-string 1)
+ (format "(%d %d)"
+ (+ offset-start (1- (match-beginning 0)))
+ (+ offset-start (1- (match-end 0))))
+ database-handle))))
+ (goto-char (point-min))
+ (setq offset-start offset-end
+ offset-end (+ buffer-size offset-end))))
+ ;; Save the range information as such in the database.
+ (put-database "range-information"
+ (let ((print-readably t))
+ (prin1-to-string range-information))
+ database-handle)
+ (close-database database-handle)
(progress-feedback-with-label 'describe-char-unicodedata-file
- "%s" 0 message)
- (while (progn
- (delete-region (point-min) (point-max))
- (insert-file-contents unidata-file-name nil
- offset-start offset-end)
- ;; If we've reached the end of the data, pass nil back to
- ;; the while loop test.
- (not (= (point-min) (point-max))))
-
- (when (= buffer-size (- (point-max) (point-min)))
- ;; If we're in the body of the file, and there's a trailing
- ;; incomplete end-line, delete it, and adjust offset-end
- ;; appropriately.
- (goto-char (point-max))
- (search-backward "\n")
- (forward-char)
- (delete-region (point) (point-max))
- (setq offset-end (+ offset-start (- (point) (point-min)))))
-
- (progress-feedback-with-label 'describe-char-unicodedata-file
- "%s" (truncate
- (* (/ offset-start size) 100))
- (concat message
- (make-string
- (mod loop-count 39) ?.)))
- (incf loop-count)
- (goto-char (point-min))
- (while (re-search-forward
- #r"^\([0-9A-F]\{4,6\}\);\([^;]*\);.*$" nil t)
- (cond
- ((and (> (- (match-end 2) (match-beginning 2)) 7)
- (equal (substring (match-string 2) -7)
- " First>"))
- ;; Start of a range. Save the start info in range-staging.
- (puthash (substring (match-string 2) 0 -7)
- (list (string-to-int (match-string 1) 16)
- (+ offset-start (1- (match-beginning 0))))
- range-staging))
- ((and (> (- (match-end 2) (match-beginning 2)) 7)
- (equal (substring (match-string 2) -6)
- " Last>"))
- ;; End of a range. Combine with the start info, save it to the
- ;; range-information range table.
- (setq range-startinfo
- (gethash (substring (match-string 2) 0 -6) range-staging))
- (assert range-startinfo nil
- "Unexpected order for range information.")
- (put-range-table
- (first range-startinfo)
- (string-to-int (match-string 1) 16)
- (list (second range-startinfo)
- (+ offset-start (1- (match-end 0))))
- range-information)
- (remhash (substring (match-string 2) 0 -6) range-staging))
- (t
- ;; Normal character. Save the associated information in the
- ;; database directly.
- (put-database (match-string 1)
- (format "(%d %d)"
- (+ offset-start (1- (match-beginning 0)))
- (+ offset-start (1- (match-end 0))))
- database-handle))))
- (goto-char (point-min))
- (setq offset-start offset-end
- offset-end (+ buffer-size offset-end))))
- ;; Save the range information as such in the database.
- (put-database "range-information"
- (let ((print-readably t))
- (prin1-to-string range-information))
- database-handle)
- (close-database database-handle)
- (progress-feedback-with-label 'describe-char-unicodedata-file
- "%s" 100 message)
- database-file-name))
+ "%s" 100 message)
+ database-file-name)))
(defun unidata-initialize-unihan-database (unihan-file-name)
"Init the berkeley or gdbm lookup table for UNIHAN-FILE-NAME.
＠＠ -562,114 +564,115 ＠＠
(check-argument-type #'file-readable-p unihan-file-name)
(unless unidata-database-format
(error 'unimplemented "No (non-SQL) DB support available"))
- (let* ((database-format unidata-database-format)
- (size (eighth (file-attributes unihan-file-name)))
- (database-file-name
- (unidata-generate-database-file-name unihan-file-name
- size database-format))
- (database-handle (open-database database-file-name database-format
- nil "rw+" #o644 'no-conversion-unix))
- (coding-system-for-read 'no-conversion-unix)
- (buffer-size 65536)
- (offset-start 0)
- (offset-end buffer-size)
- (message "Initializing Unihan database cache: ")
- (loop-count 1)
- trailing-unicode leading-unicode character-start character-end)
- (with-temp-buffer
+ (with-fboundp '(open-database put-database close-database)
+ (let* ((database-format unidata-database-format)
+ (size (eighth (file-attributes unihan-file-name)))
+ (database-file-name
+ (unidata-generate-database-file-name unihan-file-name
+ size database-format))
+ (database-handle (open-database database-file-name database-format
+ nil "rw+" #o644
+ 'no-conversion-unix))
+ (coding-system-for-read 'no-conversion-unix)
+ (buffer-size 65536)
+ (offset-start 0)
+ (offset-end buffer-size)
+ (message "Initializing Unihan database cache: ")
+ (loop-count 1)
+ trailing-unicode leading-unicode character-start character-end)
+ (with-temp-buffer
+ (progress-feedback-with-label 'describe-char-unihan-file
+ "%s" 0 message)
+ (while (progn
+ (delete-region (point-min) (point-max))
+ (insert-file-contents unihan-file-name nil
+ offset-start offset-end)
+ ;; If we've reached the end of the data, return nil to the
+ ;; while.
+ (not (= (point-min) (point-max))))
+
+ (incf loop-count)
+ (progress-feedback-with-label 'describe-char-unihan-file
+ "%s" (truncate
+ (* (/ offset-start size) 100))
+ (concat message
+ (make-string
+ (mod loop-count 44) ?.)))
+ (block 'dealing-with-chars
+ (when (= buffer-size (- (point-max) (point-min)))
+ ;; If we're in the body of the file, we need to delete the
+ ;; character info for the last character, and set offset-end
+ ;; appropriately. Otherwise, we may not be able to pick where
+ ;; the actual description of a character ends and begins.
+ ;;
+ ;; This breaks if any single Unihan character description is
+ ;; greater than the buffer size in length.
+ (goto-char (point-max))
+ (beginning-of-line)
+
+ (when (< (- (point-max) (point)) (eval-when-compile
+ (length "U+ABCDEF\t")))
+ ;; If the character ID of the last line may have been cut off,
+ ;; we need to delete all of that line here.
+ (delete-region (point) (point-max))
+ (forward-line -1))
+
+ (when (looking-at "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t")
+ (setq trailing-unicode (match-string 1)
+ trailing-unicode
+ (format "^%s\t" (regexp-quote trailing-unicode)))
+
+ (end-of-line)
+
+ ;; Go back until we hit a line that doesn't start with this
+ ;; character info.
+ (while (re-search-backward trailing-unicode nil t))
+
+ ;; The re-search-backward failed, so point is still at the end
+ ;; of the last match. Move to its beginning.
+ (beginning-of-line)
+ (delete-region (point) (point-max))
+ (setq offset-end (+ offset-start (- (point) (point-min))))))
+ (goto-char (point-min))
+ (while t
+ (when (= (point) (point-max))
+ ;; We're at the end of this part of the file.
+ (return-from 'dealing-with-chars))
+
+ (unless (re-search-forward "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t"
+ nil t)
+ ;; We're probably in the comments at the start of the
+ ;; file. No need to look for character info.
+ (return-from 'dealing-with-chars))
+
+ ;; Store where the character started.
+ (beginning-of-line)
+ (setq character-start (point))
+
+ (setq leading-unicode
+ (format "^%s\t" (regexp-quote (match-string 1))))
+
+ ;; Loop until we get past this entry.
+ (while (re-search-forward leading-unicode nil t))
+
+ ;; Now, store the information.
+ (setq leading-unicode
+ (string-to-number (substring leading-unicode 3) 16)
+ leading-unicode (format "%04X" leading-unicode)
+ character-end (prog2 (end-of-line) (point)))
+ (put-database leading-unicode
+ (format "(%d %d)"
+ (+ offset-start (1- character-start))
+ (+ offset-start (1- character-end)))
+ database-handle)
+ (forward-line)))
+ (setq offset-start offset-end
+ offset-end (+ buffer-size offset-end))))
+ (close-database database-handle)
(progress-feedback-with-label 'describe-char-unihan-file
- "%s" 0 message)
- (while (progn
- (delete-region (point-min) (point-max))
- (insert-file-contents unihan-file-name nil
- offset-start offset-end)
- ;; If we've reached the end of the data, return nil to the
- ;; while.
- (not (= (point-min) (point-max))))
-
- (incf loop-count)
- (progress-feedback-with-label 'describe-char-unihan-file
- "%s" (truncate
- (* (/ offset-start size) 100))
- (concat message
- (make-string
- (mod loop-count 44) ?.)))
- (block 'dealing-with-chars
- (when (= buffer-size (- (point-max) (point-min)))
- ;; If we're in the body of the file, we need to delete the
- ;; character info for the last character, and set offset-end
- ;; appropriately. Otherwise, we may not be able to pick where
- ;; the actual description of a character ends and
- ;; begins.
- ;;
- ;; This breaks if any single Unihan character description is
- ;; greater than the buffer size in length.
- (goto-char (point-max))
- (beginning-of-line)
-
- (when (< (- (point-max) (point)) (eval-when-compile
- (length "U+ABCDEF\t")))
- ;; If the character ID of the last line may have been cut off,
- ;; we need to delete all of that line here.
- (delete-region (point) (point-max))
- (forward-line -1))
-
- (when (looking-at "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t")
- (setq trailing-unicode (match-string 1)
- trailing-unicode
- (format "^%s\t" (regexp-quote trailing-unicode)))
-
- (end-of-line)
-
- ;; Go back until we hit a line that doesn't start with this
- ;; character info.
- (while (re-search-backward trailing-unicode nil t))
-
- ;; The re-search-backward failed, so point is still at the end
- ;; of the last match. Move to its beginning.
- (beginning-of-line)
- (delete-region (point) (point-max))
- (setq offset-end (+ offset-start (- (point) (point-min))))))
- (goto-char (point-min))
- (while t
- (when (= (point) (point-max))
- ;; We're at the end of this part of the file.
- (return-from 'dealing-with-chars))
-
- (unless (re-search-forward "^\\(U\\+[0-9A-F]\\{4,6\\}\\)\t"
- nil t)
- ;; We're probably in the comments at the start of the file. No
- ;; need to look for character info.
- (return-from 'dealing-with-chars))
-
- ;; Store where the character started.
- (beginning-of-line)
- (setq character-start (point))
-
- (setq leading-unicode
- (format "^%s\t" (regexp-quote (match-string 1))))
-
- ;; Loop until we get past this entry.
- (while (re-search-forward leading-unicode nil t))
-
- ;; Now, store the information.
- (setq leading-unicode
- (string-to-number (substring leading-unicode 3) 16)
- leading-unicode (format "%04X" leading-unicode)
- character-end (prog2 (end-of-line) (point)))
- (put-database leading-unicode
- (format "(%d %d)"
- (+ offset-start (1- character-start))
- (+ offset-start (1- character-end)))
- database-handle)
- (forward-line)))
- (setq offset-start offset-end
- offset-end (+ buffer-size offset-end))))
- (close-database database-handle)
- (progress-feedback-with-label 'describe-char-unihan-file
- "%s" 100
- message)
- database-file-name))
+ "%s" 100
+ message)
+ database-file-name)))
;; End XEmacs additions.
(defun describe-char-unicode-data (char)
＠＠ -688,52 +691,55 ＠＠
(with-temp-buffer
(let ((coding-system-for-read coding-system-for-read)
database-handle key lookup)
- (if (and describe-char-use-cache
- (prog1
- (setq database-handle
- (open-database
- (unidata-generate-database-file-name
- describe-char-unicodedata-file
- (eighth (file-attributes
- describe-char-unicodedata-file))
- unidata-database-format)
- unidata-database-format
- nil "r"
- #o644 'no-conversion-unix))
- (unless database-handle
- (warn "Could not open %s as a %s database"
- (unidata-generate-database-file-name
- describe-char-unicodedata-file
- (eighth (file-attributes
- describe-char-unicodedata-file))
- unidata-database-format)
- unidata-database-format))))
- (progn
- ;; Use the database info.
- (setq coding-system-for-read 'no-conversion-unix
- key (format "%04X" char)
- lookup (get-database key database-handle))
- (if lookup
- ;; Okay, we have information on that character in particular.
- (progn (setq lookup (read lookup))
- (insert-file-contents describe-char-unicodedata-file
- nil (first lookup)
- (second lookup)))
- ;; No information on that character in particular. Do we
- ;; have range information? If so, load and check for our
- ;; desired character.
- (setq lookup (get-database "range-information" database-handle)
- lookup (if lookup (read lookup))
- lookup (if lookup (get-range-table char lookup)))
- (when lookup
- (insert-file-contents describe-char-unicodedata-file nil
- (first lookup) (second lookup))))
- (close-database database-handle))
- ;; Otherwise, insert the whole file (the FSF approach).
- (set-buffer (get-buffer-create " *Unicode Data*"))
- (when (zerop (buffer-size))
- ;; Don't use -literally in case of DOS line endings.
- (insert-file-contents describe-char-unicodedata-file))))
+ (with-fboundp '(open-database get-database close-database)
+ (if (and describe-char-use-cache
+ (prog1
+ (setq database-handle
+ (open-database
+ (unidata-generate-database-file-name
+ describe-char-unicodedata-file
+ (eighth (file-attributes
+ describe-char-unicodedata-file))
+ unidata-database-format)
+ unidata-database-format
+ nil "r"
+ #o644 'no-conversion-unix))
+ (unless database-handle
+ (warn "Could not open %s as a %s database"
+ (unidata-generate-database-file-name
+ describe-char-unicodedata-file
+ (eighth (file-attributes
+ describe-char-unicodedata-file))
+ unidata-database-format)
+ unidata-database-format))))
+ (progn
+ ;; Use the database info.
+ (setq coding-system-for-read 'no-conversion-unix
+ key (format "%04X" char)
+ lookup (get-database key database-handle))
+ (if lookup
+ ;; Okay, we have information on that character in
+ ;; particular.
+ (progn (setq lookup (read lookup))
+ (insert-file-contents describe-char-unicodedata-file
+ nil (first lookup)
+ (second lookup)))
+ ;; No information on that character in particular. Do we
+ ;; have range information? If so, load and check for our
+ ;; desired character.
+ (setq lookup (get-database "range-information"
+ database-handle)
+ lookup (if lookup (read lookup))
+ lookup (if lookup (get-range-table char lookup)))
+ (when lookup
+ (insert-file-contents describe-char-unicodedata-file nil
+ (first lookup) (second lookup))))
+ (close-database database-handle))
+ ;; Otherwise, insert the whole file (the FSF approach).
+ (set-buffer (get-buffer-create " *Unicode Data*"))
+ (when (zerop (buffer-size))
+ ;; Don't use -literally in case of DOS line endings.
+ (insert-file-contents describe-char-unicodedata-file)))))
(goto-char (point-min))
(let ((hex (format "%04X" char))
found first last unihan-match unihan-info unihan-database-handle
＠＠ -755,14 +761,11 ＠＠
last (<= char last))
(setq found t)))
(if found
- (let ((fields (mapcar (lambda (elt)
- (if (> (length elt) 0)
- elt))
- (cdr (split-string
- (buffer-substring
- (line-beginning-position)
- (line-end-position))
- ";")))))
+ (let ((fields (cdr (nsubst nil "" (split-string
+ (buffer-substring
+ (line-beginning-position)
+ (line-end-position)) ";")
+ :test 'equal))))
;; The length depends on whether the last field was empty.
(unless (or (= 13 (length fields))
(= 14 (length fields)))
＠＠ -919,45 +922,46 ＠＠
(if (and (> (length (nth 0 fields)) 13)
(equal "<CJK Ideograph"
(substring (nth 0 fields) 0 14)))
- (if (and describe-char-unihan-file
- (setq unihan-database-handle
- (open-database
- (unidata-generate-database-file-name
- describe-char-unihan-file
- (eighth (file-attributes
- describe-char-unihan-file))
- unidata-database-format)
- unidata-database-format
- nil "r" #o644 'no-conversion-unix))
- (setq unihan-match
- (get-database (format "%04X" char)
- unihan-database-handle)
- unihan-match
- (and unihan-match (read unihan-match))))
- (with-temp-buffer
- (insert-file-contents describe-char-unihan-file
- nil (first unihan-match)
- (second unihan-match))
- (goto-char (point-min))
- (while (re-search-forward
- "^U\\+[0-9A-F]+\t\\(k[^\t]+\\)\t\\(.*\\)$"
- nil t)
- (push
- (list
- (or (gethash
- (match-string 1)
- describe-char-unihan-field-descriptions)
- (match-string 1))
- (decode-coding-string (match-string 2) 'utf-8))
- unihan-info))
- (close-database unihan-database-handle)
- unihan-info)
+ (with-fboundp '(open-database get-database close-database)
+ (if (and describe-char-unihan-file
+ (setq unihan-database-handle
+ (open-database
+ (unidata-generate-database-file-name
+ describe-char-unihan-file
+ (eighth (file-attributes
+ describe-char-unihan-file))
+ unidata-database-format)
+ unidata-database-format
+ nil "r" #o644 'no-conversion-unix))
+ (setq unihan-match
+ (get-database (format "%04X" char)
+ unihan-database-handle)
+ unihan-match
+ (and unihan-match (read unihan-match))))
+ (with-temp-buffer
+ (insert-file-contents describe-char-unihan-file
+ nil (first unihan-match)
+ (second unihan-match))
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^U\\+[0-9A-F]+\t\\(k[^\t]+\\)\t\\(.*\\)$"
+ nil t)
+ (push
+ (list
+ (or (gethash
+ (match-string 1)
+ describe-char-unihan-field-descriptions)
+ (match-string 1))
+ (decode-coding-string (match-string 2) 'utf-8))
+ unihan-info))
+ (close-database unihan-database-handle)
+ unihan-info)
;; It's a Han character, but Unihan.txt is not
;; available. Tell the user.
(list
'("Unihan"
"No Unihan information available; is \
-`describe-char-unihan-file' set, and its cache initialized?")))))))))))
+`describe-char-unihan-file' set, and its cache initialized?"))))))))))))
;; Return information about how CHAR is displayed at the buffer
;; position POS. If the selected frame is on a graphic display,
＠＠ -1030,8 +1034,7 ＠＠
(specifier-instance current-display-table (selected-window)))
(disp-table-entry (and display-table
(get-display-table char display-table)))
- (extents (mapcar #'(lambda (o) (extent-properties o))
- (extents-at pos)))
+ (extents (mapcar #'extent-properties (extents-at pos)))
(char-description (single-key-description char))
(text-props-desc
(let ((tmp-buf (generate-new-buffer " *text-props*")))
＠＠ -1202,9 +1205,9 ＠＠
(describe-char-unicode-data unicode)))
(if unicodedata
(cons (list "Unicode data" " ") unicodedata)))))
- (setq max-width (apply #'max (mapcar #'(lambda (x)
- (if (cadr x) (length (car x)) 0))
- item-list)))
+ (setq max-width
+ (reduce #'max (remove-if-not #'cadr item-list) :initial-value 0
+:key #'(lambda (object) (length (car object)))))
(when (and unicodedata (> max-width max-unicode-description-width))
(setq max-width max-unicode-description-width)
(with-temp-buffer
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Change forms like (delq nil (mapcar ...)) to (mapcan ...).
14 years
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1284645998 -3600
# Node ID 668c73e222fd7178d342124bc1f02c316855ec0e
# Parent f9ec07abdbf92606e7b25bb29538fccc24e962a4
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* x-faces.el (x-available-font-sizes):
* specifier.el (let-specifier):
* package-ui.el (pui-add-required-packages):
* msw-faces.el (mswindows-available-font-sizes):
* modeline.el (modeline-minor-mode-menu):
* minibuf.el (minibuf-directory-files):
Replace the O2N (delq nil (mapcar (lambda (W) (and X Y)) Z)) with
the ON (mapcan (lambda (W) (and X (list Y))) Z) in these files.
diff -r f9ec07abdbf9 -r 668c73e222fd lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 14:31:40 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 15:06:38 2010 +0100
＠＠ -1,3 +1,14 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * x-faces.el (x-available-font-sizes):
+ * specifier.el (let-specifier):
+ * package-ui.el (pui-add-required-packages):
+ * msw-faces.el (mswindows-available-font-sizes):
+ * modeline.el (modeline-minor-mode-menu):
+ * minibuf.el (minibuf-directory-files):
+ Replace the O2N (delq nil (mapcar (lambda (W) (and X Y)) Z)) with
+ the ON (mapcan (lambda (W) (and X (list Y))) Z) in these files.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (= < > <= >=):
diff -r f9ec07abdbf9 -r 668c73e222fd lisp/minibuf.el
--- a/lisp/minibuf.el Thu Sep 16 14:31:40 2010 +0100
+++ b/lisp/minibuf.el Thu Sep 16 15:06:38 2010 +0100
＠＠ -1569,12 +1569,13 ＠＠
(defun minibuf-directory-files (dir &optional match-regexp files-only)
(let ((want-file (or (eq files-only nil) (eq files-only t)))
(want-dirs (or (eq files-only nil) (not (eq files-only t)))))
- (delete nil
- (mapcar (function (lambda (f)
- (if (file-directory-p (expand-file-name f dir))
- (and want-dirs (file-name-as-directory f))
- (and want-file f))))
- (delete "." (directory-files dir nil match-regexp))))))
+ (mapcan
+ #'(lambda (f)
+ (and (not (equal "." f))
+ (if (file-directory-p (expand-file-name f dir))
+ (and want-dirs (list (file-name-as-directory f)))
+ (and want-file (list f)))))
+ (directory-files dir nil match-regexp))))
(defun read-file-name-2 (history prompt dir default
diff -r f9ec07abdbf9 -r 668c73e222fd lisp/modeline.el
--- a/lisp/modeline.el Thu Sep 16 14:31:40 2010 +0100
+++ b/lisp/modeline.el Thu Sep 16 15:06:38 2010 +0100
＠＠ -524,35 +524,31 ＠＠
(cons
"Minor Mode Toggles"
(sort
- (delq nil (mapcar
- #'(lambda (x)
- (let* ((toggle-sym (car x))
- (toggle-fun (or (get toggle-sym
- 'modeline-toggle-function)
- (and (commandp toggle-sym)
- toggle-sym)))
- (menu-tag (symbol-name (if (symbolp toggle-fun)
- toggle-fun
- toggle-sym))
- ;; Here a function should
- ;; maybe be invoked to
- ;; beautify the symbol's
- ;; menu appearance.
- ))
- (and toggle-fun
- (vector menu-tag
- toggle-fun
- ;; The following two are wrong
- ;; because of possible name
- ;; clashes.
- ;:active (get toggle-sym :active t)
- ;:included (get toggle-sym :included t)
- :style 'toggle
- :selected (and (boundp toggle-sym)
- toggle-sym)))))
- minor-mode-alist))
- (lambda (e1 e2)
- (string< (aref e1 0) (aref e2 0)))))
+ (mapcan
+ #'(lambda (x)
+ (let* ((toggle-sym (car x))
+ (toggle-fun (or (get toggle-sym
+ 'modeline-toggle-function)
+ (and (commandp toggle-sym)
+ toggle-sym)))
+ (menu-tag (symbol-name (if (symbolp toggle-fun)
+ toggle-fun
+ toggle-sym))
+ ;; Here a function should maybe be invoked to
+ ;; beautify the symbol's menu appearance.
+ ))
+ (and toggle-fun
+ (list (vector menu-tag
+ toggle-fun
+ ;; The following two are wrong because of
+ ;; possible name clashes.
+ ;:active (get toggle-sym :active t)
+ ;:included (get toggle-sym :included t)
+:style 'toggle
+:selected (and (boundp toggle-sym)
+ toggle-sym))))))
+ minor-mode-alist)
+ (lambda (e1 e2) (string< (aref e1 0) (aref e2 0)))))
event)))
(defvar modeline-minor-mode-map (make-sparse-keymap 'modeline-minor-mode-map)
diff -r f9ec07abdbf9 -r 668c73e222fd lisp/msw-faces.el
--- a/lisp/msw-faces.el Thu Sep 16 14:31:40 2010 +0100
+++ b/lisp/msw-faces.el Thu Sep 16 15:06:38 2010 +0100
＠＠ -268,12 +268,11 ＠＠
(concat (substring font 0 (match-beginning 3))
(substring font (match-end 3) (match-end 0))))
(sort
- (delq nil
- (mapcar #'(lambda (name)
- (and (string-match mswindows-font-regexp name)
- (string-to-int (substring name (match-beginning 3)
- (match-end 3)))))
- (font-list font device)))
+ (mapcan #'(lambda (name)
+ (and (string-match mswindows-font-regexp name)
+ (list (string-to-int (substring name (match-beginning 3)
+ (match-end 3))))))
+ (font-list font device))
#'<))
(defun mswindows-frob-font-size (font up-p device)
diff -r f9ec07abdbf9 -r 668c73e222fd lisp/package-ui.el
--- a/lisp/package-ui.el Thu Sep 16 14:31:40 2010 +0100
+++ b/lisp/package-ui.el Thu Sep 16 15:06:38 2010 +0100
＠＠ -408,26 +408,25 ＠＠
(let ((tmpbuf "*Required-Packages*") do-select)
(if pui-selected-packages
(let ((dependencies
- (delq nil (mapcar
- (lambda (pkg)
- (let ((installed
- (package-get-key pkg :version))
- (current
- (package-get-info-prop
- (package-get-info-version
- (package-get-info-find-package
- package-get-base pkg) nil)
- 'version)))
- (if (or (null installed)
- (< (if (stringp installed)
- (string-to-number installed)
- installed)
- (if (stringp current)
- (string-to-number current)
- current)))
- pkg
- nil)))
- (package-get-dependencies pui-selected-packages)))))
+ (mapcan
+ (lambda (pkg)
+ (let ((installed
+ (package-get-key pkg :version))
+ (current
+ (package-get-info-prop
+ (package-get-info-version
+ (package-get-info-find-package
+ package-get-base pkg) nil)
+ 'version)))
+ (if (or (null installed)
+ (< (if (stringp installed)
+ (string-to-number installed)
+ installed)
+ (if (stringp current)
+ (string-to-number current)
+ current)))
+ (list pkg))))
+ (package-get-dependencies pui-selected-packages))))
;; Don't change window config when asking the user if he really
;; wants to add the packages. We do this to avoid messing up
;; the window configuration if errors occur (we don't want to
diff -r f9ec07abdbf9 -r 668c73e222fd lisp/specifier.el
--- a/lisp/specifier.el Thu Sep 16 14:31:40 2010 +0100
+++ b/lisp/specifier.el Thu Sep 16 15:06:38 2010 +0100
＠＠ -521,10 +521,9 ＠＠
varlist)))
;; Bind the appropriate variables.
`(let* (,＠(mapcan #'(lambda (varel)
- (delq nil (mapcar
- #'(lambda (varcons)
- (and (cdr varcons) varcons))
- varel)))
+ (mapcan #'(lambda (varcons)
+ (and (cdr varcons) (list varcons)))
+ varel))
varlist)
,＠oldvallist)
(unwind-protect
diff -r f9ec07abdbf9 -r 668c73e222fd lisp/x-faces.el
--- a/lisp/x-faces.el Thu Sep 16 14:31:40 2010 +0100
+++ b/lisp/x-faces.el Thu Sep 16 15:06:38 2010 +0100
＠＠ -434,17 +434,17 ＠＠
(concat (substring font 0 (match-beginning 1)) "*"
(substring font (match-end 1) (match-end 0))))))
(sort
- (delq nil
- (mapcar (function
- (lambda (name)
- (and (string-match x-font-regexp name)
- (list
- (string-to-int (substring name (match-beginning 5)
- (match-end 5)))
- (string-to-int (substring name (match-beginning 6)
- (match-end 6)))
- name))))
- (font-list font device)))
+ (mapcan (function
+ (lambda (name)
+ (and (string-match x-font-regexp name)
+ (list
+ (list
+ (string-to-int (substring name (match-beginning 5)
+ (match-end 5)))
+ (string-to-int (substring name (match-beginning 6)
+ (match-end 6)))
+ name)))))
+ (font-list font device))
(function (lambda (x y) (if (= (nth 1 x) (nth 1 y))
(< (nth 0 x) (nth 0 y))
(< (nth 1 x) (nth 1 y)))))))
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Transform safe calls to (= X Y Z) to (and (= X Y) (= Y Z)); same for < > <= >=
14 years
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1284643900 -3600
# Node ID f9ec07abdbf92606e7b25bb29538fccc24e962a4
# Parent 5663ae9a89895c1f42a18d6e3d3bf08f6a5fdc55
Transform safe calls to (= X Y Z) to (and (= X Y) (= Y Z)); same for < > <= >=
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (= < > <= >=):
When these functions are handed more than two arguments, and those
arguments have no side effects, transform to a series of two
argument calls, avoiding funcall in the byte-compiled code.
* mule/mule-cmds.el (finish-set-language-environment):
Take advantage of this change in a function called 256 times at
startup.
diff -r 5663ae9a8989 -r f9ec07abdbf9 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 14:10:44 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 14:31:40 2010 +0100
＠＠ -1,3 +1,13 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (= < > <= >=):
+ When these functions are handed more than two arguments, and those
+ arguments have no side effects, transform to a series of two
+ argument calls, avoiding funcall in the byte-compiled code.
+ * mule/mule-cmds.el (finish-set-language-environment):
+ Take advantage of this change in a function called 256 times at
+ startup.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-function-form, byte-compile-quote)
diff -r 5663ae9a8989 -r f9ec07abdbf9 lisp/cl-macs.el
--- a/lisp/cl-macs.el Thu Sep 16 14:10:44 2010 +0100
+++ b/lisp/cl-macs.el Thu Sep 16 14:31:40 2010 +0100
＠＠ -3773,6 +3773,25 ＠＠
(string (cons 'concat (cddr form))))
form))
+(map nil
+ #'(lambda (function)
+ ;; There are byte codes for the two-argument versions of these
+ ;; functions; if the form has more arguments and those arguments
+ ;; have no side effects, transform to a series of two-argument
+ ;; calls.
+ (put function 'cl-compiler-macro
+ #'(lambda (form &rest arguments)
+ (if (or (null (nthcdr 3 form))
+ (notevery #'cl-safe-expr-p (cdr form)))
+ form
+ (cons 'and (mapcon
+ #'(lambda (rest)
+ (and (cdr rest)
+ `((,(car form) ,(pop rest)
+ ,(car rest)))))
+ (cdr form)))))))
+ '(= < > <= >=))
+
(mapc
#'(lambda (y)
(put (car y) 'side-effect-free t)
diff -r 5663ae9a8989 -r f9ec07abdbf9 lisp/mule/mule-cmds.el
--- a/lisp/mule/mule-cmds.el Thu Sep 16 14:10:44 2010 +0100
+++ b/lisp/mule/mule-cmds.el Thu Sep 16 14:31:40 2010 +0100
＠＠ -789,8 +789,7 ＠＠
(setq string (format "%c" unicode-error-lookup)))
;; Treat control characters specially:
(setq first-char (aref string 0))
- (when (or (and (>= first-char #x00) (<= first-char #x1f))
- (and (>= first-char #x80) (<= first-char #x9f)))
+ (when (or (<= #x00 first-char #x1f) (<= #x80 first-char #x9f))
(setq string (format "^%c" (+ ?＠ (aref string 0))))))
(setq glyph (make-glyph (vector 'string :data string)))
(set-glyph-face glyph 'unicode-invalid-sequence-warning-face)
--
“Apart from the nine-banded armadillo, man is the only natural host of
Mycobacterium leprae, although it can be grown in the footpads of mice.”
-- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments