carbon2-commit: Avoid byte compiler warnings, some needless consing, descr-text.el
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5324:09f8ed0933c7
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://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Change forms like (delq nil (mapcar ...)) to (mapcan ...).
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5323:668c73e222fd
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 15:06:38 2010 +0100
files: lisp/ChangeLog lisp/minibuf.el lisp/modeline.el lisp/msw-faces.el lisp/package-ui.el lisp/specifier.el lisp/x-faces.el
description:
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)))))))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Transform safe calls to (= X Y Z) to (and (= X Y) (= Y Z)); same for < > <= >=
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5322:f9ec07abdbf9
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 14:31:40 2010 +0100
files: lisp/ChangeLog lisp/cl-macs.el lisp/mule/mule-cmds.el
description:
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)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Warn at compile time, error at runtime, with (quote X Y), (function X Y).
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5321:5663ae9a8989
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 14:10:44 2010 +0100
files: lisp/ChangeLog lisp/bytecomp.el src/ChangeLog src/eval.c
description:
Warn at compile time, error at runtime, with (quote X Y), (function X Y).
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* bytecomp.el (byte-compile-function-form, byte-compile-quote)
(byte-compile-quote-form):
Warn at compile time, and error at runtime, if a (quote ...) or a
(function ...) form attempts to quote more than one object.
src/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* eval.c (Ffunction, Fquote):
Add argument information in the arguments: () format for these two
special operators.
diff -r 0d43872986b6 -r 5663ae9a8989 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 13:51:49 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 14:10:44 2010 +0100
＠＠ -1,3 +1,10 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * bytecomp.el (byte-compile-function-form, byte-compile-quote)
+ (byte-compile-quote-form):
+ Warn at compile time, and error at runtime, if a (quote ...) or a
+ (function ...) form attempts to quote more than one object.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
diff -r 0d43872986b6 -r 5663ae9a8989 lisp/bytecomp.el
--- a/lisp/bytecomp.el Thu Sep 16 13:51:49 2010 +0100
+++ b/lisp/bytecomp.el Thu Sep 16 14:10:44 2010 +0100
＠＠ -3581,10 +3581,13 ＠＠
;; and (funcall (function foo)) will lose with autoloads.
(defun byte-compile-function-form (form)
- (byte-compile-constant
- (cond ((symbolp (nth 1 form))
- (nth 1 form))
- ((byte-compile-lambda (nth 1 form))))))
+ (if (cddr form)
+ (byte-compile-normal-call
+ `(signal 'wrong-number-of-arguments '(function ,(length (cdr form)))))
+ (byte-compile-constant
+ (cond ((symbolp (nth 1 form))
+ (nth 1 form))
+ ((byte-compile-lambda (nth 1 form)))))))
(defun byte-compile-insert (form)
(cond ((null (cdr form))
＠＠ -3714,11 +3717,16 ＠＠
(defun byte-compile-quote (form)
- (byte-compile-constant (car (cdr form))))
+ (if (cddr form)
+ (byte-compile-normal-call
+ `(signal 'wrong-number-of-arguments '(quote ,(length (cdr form)))))
+ (byte-compile-constant (car (cdr form)))))
(defun byte-compile-quote-form (form)
- (byte-compile-constant (byte-compile-top-level (nth 1 form))))
-
+ (if (cddr form)
+ (byte-compile-normal-call
+ `(signal 'wrong-number-of-arguments '(quote ,(length (cdr form)))))
+ (byte-compile-constant (byte-compile-top-level (nth 1 form)))))
;;; control structures
diff -r 0d43872986b6 -r 5663ae9a8989 src/ChangeLog
--- a/src/ChangeLog Thu Sep 16 13:51:49 2010 +0100
+++ b/src/ChangeLog Thu Sep 16 14:10:44 2010 +0100
＠＠ -1,3 +1,9 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * eval.c (Ffunction, Fquote):
+ Add argument information in the arguments: () format for these two
+ special operators.
+
2010-09-07 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Freplace):
diff -r 0d43872986b6 -r 5663ae9a8989 src/eval.c
--- a/src/eval.c Thu Sep 16 13:51:49 2010 +0100
+++ b/src/eval.c Thu Sep 16 14:10:44 2010 +0100
＠＠ -1270,6 +1270,8 ＠＠
object preceded by `''. Thus, `'x' is equivalent to `(quote x)', in all
contexts. A print function may use either. Internally the expression is
represented as `(quote x)').
+
+arguments: (OBJECT)
*/
(args))
{
＠＠ -1350,6 +1352,8 ＠＠
object preceded by `#''. Thus, #'x is equivalent to (function x), in all
contexts. A print function may use either. Internally the expression is
represented as `(function x)').
+
+arguments: (SYMBOL-OR-LAMBDA)
*/
(args))
{
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Change (apply 'nconc (mapcar ...)) to (mapcan ...); warn about first form.
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5320:0d43872986b6
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 13:51:49 2010 +0100
files: lisp/ChangeLog lisp/byte-optimize.el lisp/bytecomp-runtime.el lisp/device.el lisp/dumped-lisp.el lisp/etags.el lisp/extents.el lisp/frame.el lisp/packages.el lisp/update-elc.el
description:
Change (apply 'nconc (mapcar ...)) to (mapcan ...); warn about first form.
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
(mapcar ...)) to (mapcan ...); warn about use of the first idiom.
* update-elc.el (do-autoload-commands):
* packages.el (packages-find-package-library-path):
* frame.el (frame-list):
* extents.el (extent-descendants):
* etags.el (buffer-tag-table-files):
* dumped-lisp.el (preloaded-file-list):
* device.el (device-list):
* bytecomp-runtime.el (proclaim-inline, proclaim-notinline)
Use #'mapcan, not (apply #'nconc (mapcar ...) in all these files.
* bytecomp-runtime.el (eval-when-compile, eval-and-compile):
In passing, mention that these macros also evaluate the body when
interpreted.
diff -r 0d436a78c514 -r 0d43872986b6 lisp/ChangeLog
--- a/lisp/ChangeLog Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 13:51:49 2010 +0100
＠＠ -1,3 +1,22 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
+ (mapcar ...)) to (mapcan ...); warn about use of the first idiom.
+
+ * update-elc.el (do-autoload-commands):
+ * packages.el (packages-find-package-library-path):
+ * frame.el (frame-list):
+ * extents.el (extent-descendants):
+ * etags.el (buffer-tag-table-files):
+ * dumped-lisp.el (preloaded-file-list):
+ * device.el (device-list):
+ * bytecomp-runtime.el (proclaim-inline, proclaim-notinline)
+ Use #'mapcan, not (apply #'nconc (mapcar ...) in all these files.
+
+ * bytecomp-runtime.el (eval-when-compile, eval-and-compile):
+ In passing, mention that these macros also evaluate the body when
+ interpreted.
+
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (the): Add a docstring and an implementation for this
diff -r 0d436a78c514 -r 0d43872986b6 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/byte-optimize.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -1119,17 +1119,26 ＠＠
;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...).
(let ((fn (nth 1 form))
(last (nth (1- (length form)) form))) ; I think this really is fastest
- (or (if (or (null last)
- (eq (car-safe last) 'quote))
- (if (listp (nth 1 last))
- (let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
- (nconc (list 'funcall fn) butlast
- (mapcar #'(lambda (x) (list 'quote x)) (nth 1 last))))
- (byte-compile-warn
- "last arg to apply can't be a literal atom: %s"
- (prin1-to-string last))
- nil))
- form)))
+ (if (and (eq last (third form))
+ (consp last)
+ (eq 'mapcar (car last))
+ (equal fn ''nconc))
+ (progn
+ (byte-compile-warn
+ "(apply 'nconc (mapcar ..)), use #'mapcan instead: %s" last)
+ (cons 'mapcan (cdr last)))
+ (or (if (or (null last)
+ (eq (car-safe last) 'quote))
+ (if (listp (nth 1 last))
+ (let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
+ (nconc (list 'funcall fn) butlast
+ (mapcar #'(lambda (x) (list 'quote x))
+ (nth 1 last))))
+ (byte-compile-warn
+ "last arg to apply can't be a literal atom: %s"
+ (prin1-to-string last))
+ nil))
+ form))))
(put 'funcall 'byte-optimizer 'byte-optimize-funcall)
(put 'apply 'byte-optimizer 'byte-optimize-apply)
diff -r 0d436a78c514 -r 0d43872986b6 lisp/bytecomp-runtime.el
--- a/lisp/bytecomp-runtime.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/bytecomp-runtime.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -53,30 +53,26 ＠＠
"Cause the named functions to be open-coded when called from compiled code.
They will only be compiled open-coded when `byte-optimize' is true."
(cons 'eval-and-compile
- (apply
- 'nconc
- (mapcar
- #'(lambda (x)
- `((or (memq (get ',x 'byte-optimizer)
- '(nil byte-compile-inline-expand))
- (error
- "%s already has a byte-optimizer, can't make it inline"
- ',x))
- (put ',x 'byte-optimizer 'byte-compile-inline-expand)))
- fns))))
+ (mapcan
+ #'(lambda (x)
+ `((or (memq (get ',x 'byte-optimizer)
+ '(nil byte-compile-inline-expand))
+ (error
+ "%s already has a byte-optimizer, can't make it inline"
+ ',x))
+ (put ',x 'byte-optimizer 'byte-compile-inline-expand)))
+ fns)))
(defmacro proclaim-notinline (&rest fns)
"Cause the named functions to no longer be open-coded."
(cons 'eval-and-compile
- (apply
- 'nconc
- (mapcar
- #'(lambda (x)
- `((if (eq (get ',x 'byte-optimizer)
- 'byte-compile-inline-expand)
- (put ',x 'byte-optimizer nil))))
- fns))))
+ (mapcan
+ #'(lambda (x)
+ `((if (eq (get ',x 'byte-optimizer)
+ 'byte-compile-inline-expand)
+ (put ',x 'byte-optimizer nil))))
+ fns)))
;; This has a special byte-hunk-handler in bytecomp.el.
(defmacro defsubst (name arglist &rest body)
＠＠ -163,7 +159,7 ＠＠
(put 'eval-when-compile 'lisp-indent-hook 0)
(defmacro eval-when-compile (&rest body)
- "Like `progn', but evaluates the body at compile time.
+ "Like `progn', but evaluates BODY at compile time, and when interpeted.
The result of the body appears to the compiler as a quoted constant."
;; Not necessary because we have it in b-c-initial-macro-environment
;; (list 'quote (eval (cons 'progn body)))
＠＠ -171,7 +167,8 ＠＠
(put 'eval-and-compile 'lisp-indent-hook 0)
(defmacro eval-and-compile (&rest body)
- "Like `progn', but evaluates the body at compile time and at load time."
+ "Like `progn', but evaluates the body at compile time and at load time,
+and when interpreted."
;; Remember, it's magic.
(cons 'progn body))
diff -r 0d436a78c514 -r 0d43872986b6 lisp/device.el
--- a/lisp/device.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/device.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -45,7 +45,7 ＠＠
(defun device-list ()
"Return a list of all devices."
- (apply 'nconc (mapcar 'console-device-list (console-list))))
+ (mapcan 'console-device-list (console-list)))
(defun device-type (&optional device)
"Return the type of the specified device (e.g. `x' or `tty').
diff -r 0d436a78c514 -r 0d43872986b6 lisp/dumped-lisp.el
--- a/lisp/dumped-lisp.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/dumped-lisp.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -300,7 +300,4 ＠＠
))
(setq preloaded-file-list
- (apply #'nconc
- (mapcar #'(lambda (x)
- (if (listp x) x (list x)))
- preloaded-file-list)))
+ (mapcan #'(lambda (x) (if (listp x) x (list x))) preloaded-file-list))
diff -r 0d436a78c514 -r 0d43872986b6 lisp/etags.el
--- a/lisp/etags.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/etags.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -439,8 +439,7 ＠＠
(defun buffer-tag-table-files ()
"Returns a list of all files referenced by all TAGS tables that
this buffer uses."
- (apply #'append
- (mapcar #'tag-table-files (buffer-tag-table-list))))
+ (mapcan #'tag-table-files (buffer-tag-table-list)))
;; Building the completion table
diff -r 0d436a78c514 -r 0d43872986b6 lisp/extents.el
--- a/lisp/extents.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/extents.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -109,7 +109,7 ＠＠
EXTENT, until no more children can be found."
(let ((children (extent-children extent)))
(if children
- (apply 'nconc (mapcar 'extent-descendants children))
+ (mapcan 'extent-descendants children)
(list extent))))
(defun set-extent-keymap (extent keymap)
diff -r 0d436a78c514 -r 0d43872986b6 lisp/frame.el
--- a/lisp/frame.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/frame.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -861,7 +861,7 ＠＠
(defun frame-list ()
"Return a list of all frames on all devices/consoles."
;; Lists are copies, so nconc is safe here.
- (apply 'nconc (mapcar 'device-frame-list (device-list))))
+ (mapcan #'device-frame-list (device-list)))
(defun frame-type (&optional frame)
"Return the type of the specified frame (e.g. `x' or `tty').
diff -r 0d436a78c514 -r 0d43872986b6 lisp/packages.el
--- a/lisp/packages.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/packages.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -467,13 +467,11 ＠＠
PACKAGE-HIERARCHIES is a list of package hierarchies.
SUFFIXES is a list of names of hierarchy subdirectories to look for."
(let ((directories
- (apply
- #'nconc
- (mapcar #'(lambda (hierarchy)
- (mapcar #'(lambda (suffix)
- (file-name-as-directory (concat hierarchy suffix)))
- suffixes))
- package-hierarchies))))
+ (mapcan #'(lambda (hierarchy)
+ (mapcar #'(lambda (suffix)
+ (file-name-as-directory (concat hierarchy suffix)))
+ suffixes))
+ package-hierarchies)))
(paths-directories-which-exist directories)))
(defun packages-find-package-load-path (package-hierarchies)
diff -r 0d436a78c514 -r 0d43872986b6 lisp/update-elc.el
--- a/lisp/update-elc.el Thu Sep 16 13:36:03 2010 +0100
+++ b/lisp/update-elc.el Thu Sep 16 13:51:49 2010 +0100
＠＠ -367,21 +367,19 ＠＠
;; load-ignore-elc-files because byte-optimize gets autoloaded
;; from bytecomp.
(let ((recompile-bc-bootstrap
- (apply #'nconc
- (mapcar
- #'(lambda (arg)
- (when (member arg update-elc-files-to-compile)
- (append '("-f" "batch-byte-compile-one-file")
- (list arg))))
- bc-bootstrap)))
+ (mapcan
+ #'(lambda (arg)
+ (when (member arg update-elc-files-to-compile)
+ (append '("-f" "batch-byte-compile-one-file")
+ (list arg))))
+ bc-bootstrap))
(recompile-bootstrap-other
- (apply #'nconc
- (mapcar
- #'(lambda (arg)
- (when (member arg update-elc-files-to-compile)
- (append '("-f" "batch-byte-compile-one-file")
- (list arg))))
- bootstrap-other))))
+ (mapcan
+ #'(lambda (arg)
+ (when (member arg update-elc-files-to-compile)
+ (append '("-f" "batch-byte-compile-one-file")
+ (list arg))))
+ bootstrap-other)))
(mapc
#'(lambda (arg)
(setq update-elc-files-to-compile
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Add an implementation for #'the, cl-macs.el
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5319:0d436a78c514
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Thu Sep 16 13:36:03 2010 +0100
files: lisp/ChangeLog lisp/bytecomp.el lisp/cl-macs.el
description:
Add an implementation for #'the, cl-macs.el
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-macs.el (the): Add a docstring and an implementation for this
macro.
* bytecomp.el (byte-compile-initial-macro-environment): Add #'the
to this, checking byte-compile-delete-errors to decide whether to
make the type assertion. Change the initvalue to use backquote and
preceding commas for the lambda expressions, to allow the latter
to be compiled.
diff -r 75bcb5bef459 -r 0d436a78c514 lisp/ChangeLog
--- a/lisp/ChangeLog Tue Sep 07 17:03:46 2010 +0100
+++ b/lisp/ChangeLog Thu Sep 16 13:36:03 2010 +0100
＠＠ -1,3 +1,13 ＠＠
+2010-09-16 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-macs.el (the): Add a docstring and an implementation for this
+ macro.
+ * bytecomp.el (byte-compile-initial-macro-environment): Add #'the
+ to this, checking byte-compile-delete-errors to decide whether to
+ make the type assertion. Change the initvalue to use backquote and
+ preceding commas for the lambda expressions, to allow the latter
+ to be compiled.
+
2010-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-seq.el (replace):
diff -r 75bcb5bef459 -r 0d436a78c514 lisp/bytecomp.el
--- a/lisp/bytecomp.el Tue Sep 07 17:03:46 2010 +0100
+++ b/lisp/bytecomp.el Thu Sep 16 13:36:03 2010 +0100
＠＠ -493,13 +493,21 ＠＠
(fset (car elt) (cdr elt)))))))
(defconst byte-compile-initial-macro-environment
- '((byte-compiler-options . (lambda (&rest forms)
- (apply 'byte-compiler-options-handler forms)))
- (eval-when-compile . (lambda (&rest body)
- (list 'quote (byte-compile-eval (cons 'progn body)))))
- (eval-and-compile . (lambda (&rest body)
- (byte-compile-eval (cons 'progn body))
- (cons 'progn body))))
+ `((byte-compiler-options
+ . ,#'(lambda (&rest forms)
+ (apply 'byte-compiler-options-handler forms)))
+ (eval-when-compile
+ . ,#'(lambda (&rest body)
+ (list 'quote (byte-compile-eval (cons 'progn body)))))
+ (eval-and-compile
+ . ,#'(lambda (&rest body)
+ (byte-compile-eval (cons 'progn body))
+ (cons 'progn body)))
+ (the .
+ ,#'(lambda (&rest body)
+ (if byte-compile-delete-errors
+ (second body)
+ (apply (cdr (symbol-function 'the)) body)))))
"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 75bcb5bef459 -r 0d436a78c514 lisp/cl-macs.el
--- a/lisp/cl-macs.el Tue Sep 07 17:03:46 2010 +0100
+++ b/lisp/cl-macs.el Thu Sep 16 13:36:03 2010 +0100
＠＠ -1962,7 +1962,19 ＠＠
;;;###autoload
(defmacro locally (&rest body) (cons 'progn body))
;;;###autoload
-(defmacro the (type form) form)
+(defmacro the (type form)
+ "Assert that FORM gives a result of type TYPE, and return FORM.
+
+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."
+ (if (cl-safe-expr-p form)
+ `(prog1 ,form (assert ,(cl-make-type-test form type) t))
+ (let ((saved (gensym)))
+ `(let ((,saved ,form))
+ (prog1 ,saved (assert ,(cl-make-type-test saved type) t))))))
(defvar cl-proclaim-history t) ; for future compilers
(defvar cl-declare-stack t) ; for future compilers
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Replace a doubled semi-colon with a single semi-colon, fns.c, for VS6's sake.
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5318:75bcb5bef459
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Tue Sep 07 17:03:46 2010 +0100
files: src/ChangeLog src/fns.c
description:
Replace a doubled semi-colon with a single semi-colon, fns.c, for VS6's sake.
src/ChangeLog addition:
2010-09-07 Aidan Kehoe <kehoea(a)parhasard.net>
* fns.c (Freplace):
Replace an accidental double semi-colon with a single semi-colon,
hopefully fixing Vin's Visual Studio 6 build. (Visual Studio 2005
had no problem with it, oddly.)
diff -r 69f687b3ba9d -r 75bcb5bef459 src/ChangeLog
--- a/src/ChangeLog Mon Sep 06 17:29:51 2010 +0100
+++ b/src/ChangeLog Tue Sep 07 17:03:46 2010 +0100
＠＠ -1,3 +1,10 ＠＠
+2010-09-07 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * fns.c (Freplace):
+ Replace an accidental double semi-colon with a single semi-colon,
+ hopefully fixing Vin's Visual Studio 6 build. (Visual Studio 2005
+ had no problem with it, oddly.)
+
2010-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
Move #'replace to C; add bounds checking to it and to #'fill.
diff -r 69f687b3ba9d -r 75bcb5bef459 src/fns.c
--- a/src/fns.c Mon Sep 06 17:29:51 2010 +0100
+++ b/src/fns.c Tue Sep 07 17:03:46 2010 +0100
＠＠ -5862,7 +5862,7 ＠＠
{
Ibyte *staging, *cursor;
Elemcount count, len1 = string_char_length (sequence1);
- Elemcount len2 = XINT (Flength (sequence2)), ii = 0;;
+ Elemcount len2 = XINT (Flength (sequence2)), ii = 0;
Lisp_Object obj;
check_sequence_range (sequence1, start1, end1, make_int (len1));
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Move #'replace to C, add bounds-checking to it and to #'fill.
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5317:69f687b3ba9d
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Mon Sep 06 17:29:51 2010 +0100
files: lisp/ChangeLog lisp/cl-seq.el src/ChangeLog src/fns.c
description:
Move #'replace to C, add bounds-checking to it and to #'fill.
2010-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
Move #'replace to C; add bounds checking to it and to #'fill.
* fns.c (Fsubseq, Ffill, mapcarX):
Don't #'nreverse in #'subseq, use fill_string_range and check
bounds in #'fill, use replace_string_range() in #'map-into
avoiding quadratic time when modfiying the string.
* fns.c (check_sequence_range, fill_string_range)
(replace_string_range, replace_string_range_1, Freplace):
New functions; check that arguments fit sequence dimensions, fill
a string range with a given character, replace a string range from
an Ibyte pointer.
diff -r dceee3855f15 -r 69f687b3ba9d lisp/ChangeLog
--- a/lisp/ChangeLog Sun Sep 05 20:31:05 2010 +0100
+++ b/lisp/ChangeLog Mon Sep 06 17:29:51 2010 +0100
＠＠ -1,3 +1,9 ＠＠
+2010-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cl-seq.el (replace):
+ Move this function, with added bounds-checking per ANSI Common
+ Lisp, to fns.c.
+
2010-09-05 Aidan Kehoe <kehoea(a)parhasard.net>
* x-compose.el (define-compose-map, compose-map)
diff -r dceee3855f15 -r 69f687b3ba9d lisp/cl-seq.el
--- a/lisp/cl-seq.el Sun Sep 05 20:31:05 2010 +0100
+++ b/lisp/cl-seq.el Mon Sep 06 17:29:51 2010 +0100
＠＠ -142,48 +142,7 ＠＠
(defvar cl-if) (defvar cl-if-not)
(defvar cl-key)
-(defun replace (cl-seq1 cl-seq2 &rest cl-keys)
- "Replace the elements of SEQ1 with the elements of SEQ2.
-SEQ1 is destructively modified, then returned.
-Keywords supported: :start1 :end1 :start2 :end2
-:start1 and :end1 specify a subsequence of SEQ1, and :start2 and :end2 a
-subsequence of SEQ2; see `search' for more information."
- (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) ()
- (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1))
- (or (= cl-start1 cl-start2)
- (let* ((cl-len (length cl-seq1))
- (cl-n (min (- (or cl-end1 cl-len) cl-start1)
- (- (or cl-end2 cl-len) cl-start2))))
- (while (>= (setq cl-n (1- cl-n)) 0)
- (cl-set-elt cl-seq1 (+ cl-start1 cl-n)
- (elt cl-seq2 (+ cl-start2 cl-n))))))
- (if (listp cl-seq1)
- (let ((cl-p1 (nthcdr cl-start1 cl-seq1))
- (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000)))
- (if (listp cl-seq2)
- (let ((cl-p2 (nthcdr cl-start2 cl-seq2))
- (cl-n (min cl-n1
- (if cl-end2 (- cl-end2 cl-start2) 4000000))))
- (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0))
- (setcar cl-p1 (car cl-p2))
- (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))))
- (setq cl-end2 (min (or cl-end2 (length cl-seq2))
- (+ cl-start2 cl-n1)))
- (while (and cl-p1 (< cl-start2 cl-end2))
- (setcar cl-p1 (aref cl-seq2 cl-start2))
- (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2)))))
- (setq cl-end1 (min (or cl-end1 (length cl-seq1))
- (+ cl-start1 (- (or cl-end2 (length cl-seq2))
- cl-start2))))
- (if (listp cl-seq2)
- (let ((cl-p2 (nthcdr cl-start2 cl-seq2)))
- (while (< cl-start1 cl-end1)
- (aset cl-seq1 cl-start1 (car cl-p2))
- (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1))))
- (while (< cl-start1 cl-end1)
- (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2))
- (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1))))))
- cl-seq1))
+;; XEmacs; #'replace is in fns.c.
(defun remove* (cl-item cl-seq &rest cl-keys)
"Remove all occurrences of ITEM in SEQ.
diff -r dceee3855f15 -r 69f687b3ba9d src/ChangeLog
--- a/src/ChangeLog Sun Sep 05 20:31:05 2010 +0100
+++ b/src/ChangeLog Mon Sep 06 17:29:51 2010 +0100
＠＠ -1,3 +1,18 ＠＠
+2010-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Move #'replace to C; add bounds checking to it and to #'fill.
+
+ * fns.c (Fsubseq, Ffill, mapcarX):
+ Don't #'nreverse in #'subseq, use fill_string_range and check
+ bounds in #'fill, use replace_string_range() in #'map-into
+ avoiding quadratic time when modfiying the string.
+
+ * fns.c (check_sequence_range, fill_string_range)
+ (replace_string_range, replace_string_range_1, Freplace):
+ New functions; check that arguments fit sequence dimensions, fill
+ a string range with a given character, replace a string range from
+ an Ibyte pointer.
+
2010-09-05 Aidan Kehoe <kehoea(a)parhasard.net>
* chartab.c (char_table_default_for_type,
diff -r dceee3855f15 -r 69f687b3ba9d src/fns.c
--- a/src/fns.c Sun Sep 05 20:31:05 2010 +0100
+++ b/src/fns.c Mon Sep 06 17:29:51 2010 +0100
＠＠ -54,11 +54,12 ＠＠
/* NOTE: This symbol is also used in lread.c */
#define FEATUREP_SYNTAX
-Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill;
+Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill, Qreplace;
Lisp_Object Qidentity;
Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Q_from_end, Q_initial_value;
Lisp_Object Qmapconcat, QmapcarX, Qmapvector, Qmapcan, Qmapc, Qmap, Qmap_into;
Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce;
+Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2;
Lisp_Object Qbase64_conversion_error;
＠＠ -71,6 +72,20 ＠＠
mapping_interaction_error (Lisp_Object func, Lisp_Object object)
{
invalid_state_2 ("object modified while traversing it", func, object);
+}
+
+static void
+check_sequence_range (Lisp_Object sequence, Lisp_Object start,
+ Lisp_Object end, Lisp_Object length)
+{
+ Elemcount starting = XINT (start), ending, len = XINT (length);
+
+ ending = NILP (end) ? XINT (length) : XINT (end);
+
+ if (!(0 <= starting && starting <= ending && ending <= len))
+ {
+ args_out_of_range_3 (sequence, start, make_int (ending));
+ }
}
static Lisp_Object
＠＠ -885,7 +900,7 ＠＠
{
CHECK_CHAR_COERCE_INT (elt);
string_result_ptr += set_itext_ichar (string_result_ptr,
- XCHAR (elt));
+ XCHAR (elt));
}
}
if (args_mse)
＠＠ -1044,8 +1059,8 ＠＠
e = len + e;
}
- if (!(0 <= s && s <= e && e <= len))
- args_out_of_range_3 (sequence, make_int (s), make_int (e));
+ check_sequence_range (sequence, make_int (s), make_int (e),
+ make_int (len));
if (VECTORP (sequence))
{
＠＠ -1060,18 +1075,24 ＠＠
}
else if (LISTP (sequence))
{
- Lisp_Object result = Qnil;
+ Lisp_Object result = Qnil, result_tail;
EMACS_INT i;
sequence = Fnthcdr (make_int (s), sequence);
- for (i = s; i < e; i++)
- {
- result = Fcons (Fcar (sequence), result);
+ if (s < e)
+ {
+ result = result_tail = Fcons (Fcar (sequence), Qnil);
sequence = Fcdr (sequence);
- }
-
- return Fnreverse (result);
+ for (i = s + 1; i < e; i++)
+ {
+ XSETCDR (result_tail, Fcons (Fcar (sequence), Qnil));
+ sequence = Fcdr (sequence);
+ result_tail = XCDR (result_tail);
+ }
+ }
+
+ return result;
}
else if (BIT_VECTORP (sequence))
{
＠＠ -3872,6 +3893,29 ＠＠
}
+static Lisp_Object replace_string_range_1 (Lisp_Object dest,
+ Lisp_Object start,
+ Lisp_Object end,
+ const Ibyte *source,
+ const Ibyte *source_limit,
+ Lisp_Object item);
+
+/* Fill the substring of DEST beginning at START and ending before END with
+ the character ITEM. If DEST does not have sufficient space for END -
+ START characters at START, write as many as is possible without changing
+ the character length of DEST. Update the string modification flag and do
+ any sledgehammer checks we have turned on.
+
+ START must be a Lisp integer. END can be nil, indicating the length of the
+ string, or a Lisp integer. The condition (<= 0 START END (length DEST))
+ must hold, or fill_string_range() will signal an error. */
+static Lisp_Object
+fill_string_range (Lisp_Object dest, Lisp_Object item, Lisp_Object start,
+ Lisp_Object end)
+{
+ return replace_string_range_1 (dest, start, end, NULL, NULL, item);
+}
+
DEFUN ("fill", Ffill, 2, MANY, 0, /*
Destructively modify SEQUENCE by replacing each element with ITEM.
SEQUENCE is a list, vector, bit vector, or string.
＠＠ -3881,21 +3925,20 ＠＠
exclusive upper bound on the elements of SEQUENCE to be modified, and
defaults to the length of SEQUENCE.
-arguments: (SEQUENCE ITEM &key (START 0) END)
+arguments: (SEQUENCE ITEM &key (START 0) (END (length SEQUENCE)))
*/
(int nargs, Lisp_Object *args))
{
Lisp_Object sequence = args[0];
Lisp_Object item = args[1];
- Elemcount starting = 0, ending = EMACS_INT_MAX, ii;
-
- PARSE_KEYWORDS (Qfill, nargs, args, 2, 2, (start, end),
- (start = Qzero, end = Qunbound), 0);
+ Elemcount starting = 0, ending = EMACS_INT_MAX, ii, len;
+
+ PARSE_KEYWORDS (Qfill, nargs, args, 2, 2, (start, end), (start = Qzero), 0);
CHECK_NATNUM (start);
starting = XINT (start);
- if (!UNBOUNDP (end))
+ if (!NILP (end))
{
CHECK_NATNUM (end);
ending = XINT (end);
＠＠ -3904,49 +3947,21 ＠＠
retry:
if (STRINGP (sequence))
{
- Bytecount prefix_bytecount, item_bytecount, delta;
- Ibyte item_buf[MAX_ICHAR_LEN];
- Ibyte *p, *pend;
-
CHECK_CHAR_COERCE_INT (item);
-
CHECK_LISP_WRITEABLE (sequence);
- sledgehammer_check_ascii_begin (sequence);
- item_bytecount = set_itext_ichar (item_buf, XCHAR (item));
-
- p = XSTRING_DATA (sequence);
- p = (Ibyte *) itext_n_addr (p, starting);
- prefix_bytecount = p - XSTRING_DATA (sequence);
-
- ending = min (ending, string_char_length (sequence));
- pend = (Ibyte *) itext_n_addr (p, ending - starting);
- delta = ((ending - starting) * item_bytecount) - (pend - p);
-
- /* Resize the string if the bytecount for the area being modified is
- different. */
- if (delta)
- {
- resize_string (sequence, prefix_bytecount, delta);
- /* No need to zero-terminate the string, resize_string has done
- that for us. */
- p = XSTRING_DATA (sequence) + prefix_bytecount;
- pend = p + ((ending - starting) * item_bytecount);
- }
-
- for (; p < pend; p += item_bytecount)
- memcpy (p, item_buf, item_bytecount);
-
-
- init_string_ascii_begin (sequence);
- bump_string_modiff (sequence);
- sledgehammer_check_ascii_begin (sequence);
+
+ fill_string_range (sequence, item, start, end);
}
else if (VECTORP (sequence))
{
Lisp_Object *p = XVECTOR_DATA (sequence);
+
CHECK_LISP_WRITEABLE (sequence);
-
- ending = min (ending, XVECTOR_LENGTH (sequence));
+ len = XVECTOR_LENGTH (sequence);
+
+ check_sequence_range (sequence, start, end, make_int (len));
+ ending = min (ending, len);
+
for (ii = starting; ii < ending; ++ii)
{
p[ii] = item;
＠＠ -3956,11 +3971,15 ＠＠
{
Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
int bit;
+
CHECK_BIT (item);
bit = XINT (item);
CHECK_LISP_WRITEABLE (sequence);
-
- ending = min (ending, bit_vector_length (v));
+ len = bit_vector_length (v);
+
+ check_sequence_range (sequence, start, end, make_int (len));
+ ending = min (ending, len);
+
for (ii = starting; ii < ending; ++ii)
{
set_bit_vector_bit (v, ii, bit);
＠＠ -3985,6 +4004,11 ＠＠
}
++counting;
}
+
+ if (counting != ending)
+ {
+ check_sequence_range (sequence, start, end, Flength (sequence));
+ }
}
else
{
＠＠ -4129,6 +4153,24 ＠＠
}
+/* Replace the substring of DEST beginning at START and ending before END
+ with the text at SOURCE, which is END - START characters long and
+ SOURCE_LIMIT - SOURCE octets long. If DEST does not have sufficient
+ space for END - START characters at START, write as many as is possible
+ without changing the length of DEST. Update the string modification flag
+ and do any sledgehammer checks we have turned on in this build.
+
+ START must be a Lisp integer. END can be nil, indicating the length of the
+ string, or a Lisp integer. The condition (<= 0 START END (length DEST))
+ must hold, or replace_string_range() will signal an error. */
+static Lisp_Object
+replace_string_range (Lisp_Object dest, Lisp_Object start, Lisp_Object end,
+ const Ibyte *source, const Ibyte *source_limit)
+{
+ return replace_string_range_1 (dest, start, end, source, source_limit,
+ Qnil);
+}
+
/* This is the guts of several mapping functions.
Call FUNCTION CALL_COUNT times, with NSEQUENCES arguments each time,
＠＠ -4168,6 +4210,7 ＠＠
{
Lisp_Object called, *args;
struct gcpro gcpro1, gcpro2;
+ Ibyte *lisp_vals_staging, *cursor;
int i, j;
assert ((EQ (caller, Qsome) || EQ (caller, Qevery)) ? vals == NULL : 1);
＠＠ -4224,9 +4267,15 ＠＠
if (!EQ (caller, Qsome) && !EQ (caller, Qevery))
{
assert (LRECORDP (lisp_vals));
+
lisp_vals_type
= (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type;
- assert (NILP (lisp_vals) || lisp_vals_type != lrecord_type_symbol);
+
+ if (lrecord_type_string == lisp_vals_type)
+ {
+ lisp_vals_staging = cursor
+ = alloca_ibytes (call_count * MAX_ICHAR_LEN);
+ }
}
for (i = 0; i < call_count; ++i)
＠＠ -4305,8 +4354,7 ＠＠
switch (lisp_vals_type)
{
case lrecord_type_symbol:
- /* This is #'mapc; the result of the funcall is
- discarded. */
+ /* Discard the result of funcall. */
break;
case lrecord_type_cons:
{
＠＠ -4331,10 +4379,8 ＠＠
}
case lrecord_type_string:
{
- /* If this ever becomes a code hotspot, we can keep
- around pointers into the data of the string, checking
- each time that it hasn't been relocated. */
- Faset (lisp_vals, make_int (i), called);
+ CHECK_CHAR_COERCE_INT (called);
+ cursor += set_itext_ichar (cursor, XCHAR (called));
break;
}
case lrecord_type_bit_vector:
＠＠ -4354,7 +4400,15 ＠＠
}
}
}
- }
+
+ if (!EQ (caller, Qsome) && !EQ (caller, Qevery) &&
+ lrecord_type_string == lisp_vals_type)
+ {
+ replace_string_range (lisp_vals, Qzero, make_int (call_count),
+ lisp_vals_staging, cursor);
+ }
+ }
+
UNGCPRO;
}
＠＠ -5302,6 +5356,590 ＠＠
return old;
}
+/* This function is the implementation of fill_string_range() and
+ replace_string_range(); see the comments for those functions. */
+static Lisp_Object
+replace_string_range_1 (Lisp_Object dest, Lisp_Object start, Lisp_Object end,
+ const Ibyte *source, const Ibyte *source_limit,
+ Lisp_Object item)
+{
+ Ibyte *destp = XSTRING_DATA (dest), *p = destp,
+ *pend = p + XSTRING_LENGTH (dest), *pcursor, item_buf[MAX_ICHAR_LEN];
+ Bytecount prefix_bytecount, source_len = source_limit - source;
+ Charcount ii = 0, starting = XINT (start), ending, len;
+ Elemcount delta;
+
+ while (ii < starting && p < pend)
+ {
+ INC_IBYTEPTR (p);
+ ii++;
+ }
+
+ pcursor = p;
+
+ if (NILP (end))
+ {
+ while (pcursor < pend)
+ {
+ INC_IBYTEPTR (pcursor);
+ ii++;
+ }
+
+ ending = len = ii;
+ }
+ else
+ {
+ ending = XINT (end);
+ while (ii < ending && pcursor < pend)
+ {
+ INC_IBYTEPTR (pcursor);
+ ii++;
+ }
+ }
+
+ if (pcursor == pend)
+ {
+ /* We have the length, check it for our callers. */
+ check_sequence_range (dest, start, end, make_int (ii));
+ }
+
+ if (!(p == pend || p == pcursor))
+ {
+ prefix_bytecount = p - destp;
+
+ if (!NILP (item))
+ {
+ assert (source == NULL && source_limit == NULL);
+ source_len = set_itext_ichar (item_buf, XCHAR (item));
+ delta = (source_len * (ending - starting)) - (pcursor - p);
+ }
+ else
+ {
+ assert (source != NULL && source_limit != NULL);
+ delta = source_len - (pcursor - p);
+ }
+
+ if (delta)
+ {
+ resize_string (dest, prefix_bytecount, delta);
+ destp = XSTRING_DATA (dest);
+ pcursor = destp + prefix_bytecount + (pcursor - p);
+ p = destp + prefix_bytecount;
+ }
+
+ if (CHARP (item))
+ {
+ while (starting < ending)
+ {
+ memcpy (p, item_buf, source_len);
+ p += source_len;
+ starting++;
+ }
+ }
+ else
+ {
+ while (starting < ending && source < source_limit)
+ {
+ source_len = itext_copy_ichar (source, p);
+ p += source_len, source += source_len;
+ }
+ }
+
+ init_string_ascii_begin (dest);
+ bump_string_modiff (dest);
+ sledgehammer_check_ascii_begin (dest);
+ }
+
+ return dest;
+}
+
+DEFUN ("replace", Freplace, 2, MANY, 0, /*
+Replace the elements of SEQUENCE-ONE with the elements of SEQUENCE-TWO.
+
+SEQUENCE-ONE is destructively modified, and returned. Its length is not
+changed.
+
+Keywords:start1 and :end1 specify a subsequence of SEQUENCE-ONE, and
+:start2 and :end2 a subsequence of SEQUENCE-TWO. See `search' for more
+information.
+
+arguments: (SEQUENCE-ONE SEQUENCE-TWO &key (START1 0) (END1 (length SEQUENCE-ONE)) (START2 0) (END2 (length SEQUENCE-TWO)))
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object sequence1 = args[0], sequence2 = args[1],
+ result = sequence1;
+ Elemcount starting1, ending1 = EMACS_INT_MAX, starting2;
+ Elemcount ending2 = EMACS_INT_MAX, counting, startcounting;
+ Boolint sequence1_listp, sequence2_listp,
+ overwriting = EQ (sequence1, sequence2);
+
+ PARSE_KEYWORDS (Qreplace, nargs, args, 2, 4, (start1, end1, start2, end2),
+ (start1 = start2 = Qzero), 0);
+
+ CHECK_SEQUENCE (sequence1);
+ CHECK_LISP_WRITEABLE (sequence1);
+
+ CHECK_SEQUENCE (sequence2);
+
+ CHECK_NATNUM (start1);
+ starting1 = XINT (start1);
+ CHECK_NATNUM (start2);
+ starting2 = XINT (start2);
+
+ if (!NILP (end1))
+ {
+ CHECK_NATNUM (end1);
+ ending1 = XINT (end1);
+
+ if (!(starting1 <= ending1))
+ {
+ args_out_of_range_3 (sequence1, start1, end1);
+ }
+ }
+
+ if (!NILP (end2))
+ {
+ CHECK_NATNUM (end2);
+ ending2 = XINT (end2);
+
+ if (!(starting2 <= ending2))
+ {
+ args_out_of_range_3 (sequence1, start2, end2);
+ }
+ }
+
+ sequence1_listp = LISTP (sequence1);
+ sequence2_listp = LISTP (sequence2);
+
+ overwriting = overwriting && starting2 <= starting1;
+
+ if (sequence1_listp && !ZEROP (start1))
+ {
+ Lisp_Object nthcdrd = Fnthcdr (start1, sequence1);
+
+ if (NILP (nthcdrd))
+ {
+ check_sequence_range (sequence1, start1, end1, Flength (sequence1));
+ /* Give up early here. */
+ return result;
+ }
+
+ sequence1 = nthcdrd;
+ ending1 -= starting1;
+ starting1 = 0;
+ }
+
+ if (sequence2_listp && !ZEROP (start2))
+ {
+ Lisp_Object nthcdrd = Fnthcdr (start2, sequence2);
+
+ if (NILP (nthcdrd))
+ {
+ check_sequence_range (sequence1, start1, end1, Flength (sequence1));
+ /* Nothing available to replace sequence1's contents. */
+ return result;
+ }
+
+ sequence2 = nthcdrd;
+ ending2 -= starting2;
+ starting2 = 0;
+ }
+
+ if (overwriting)
+ {
+ if (EQ (start1, start2))
+ {
+ return result;
+ }
+
+ /* Our ranges may overlap. Save the data that might be overwritten. */
+
+ if (CONSP (sequence2))
+ {
+ Elemcount len = XINT (Flength (sequence2));
+ Lisp_Object *subsequence
+ = alloca_array (Lisp_Object, min (ending2, len));
+ Elemcount counting = 0, ii = 0;
+
+ LIST_LOOP_2 (elt, sequence2)
+ {
+ if (counting == ending2)
+ {
+ break;
+ }
+
+ subsequence[ii++] = elt;
+ counting++;
+ }
+
+ check_sequence_range (sequence1, start1, end1,
+ /* The XINT (start2) is intentional here; we
+ called #'length after doing (nthcdr
+ start2 sequence2). */
+ make_int (XINT (start2) + len));
+ check_sequence_range (sequence2, start2, end2,
+ make_int (XINT (start2) + len));
+
+ while (starting1 < ending1
+ && starting2 < ending2 && !NILP (sequence1))
+ {
+ XSETCAR (sequence1, subsequence[starting2]);
+ sequence1 = XCDR (sequence1);
+ starting1++;
+ starting2++;
+ }
+ }
+ else if (STRINGP (sequence2))
+ {
+ Ibyte *p = XSTRING_DATA (sequence2),
+ *pend = p + XSTRING_LENGTH (sequence2), *pcursor,
+ *staging;
+ Bytecount ii = 0;
+
+ while (ii < starting2 && p < pend)
+ {
+ INC_IBYTEPTR (p);
+ ii++;
+ }
+
+ pcursor = p;
+
+ while (ii < ending2 && starting1 < ending1 && pcursor < pend)
+ {
+ INC_IBYTEPTR (pcursor);
+ starting1++;
+ ii++;
+ }
+
+ if (pcursor == pend)
+ {
+ check_sequence_range (sequence1, start1, end1, make_int (ii));
+ check_sequence_range (sequence2, start2, end2, make_int (ii));
+ }
+ else
+ {
+ assert ((pcursor - p) > 0);
+ staging = alloca_ibytes (pcursor - p);
+ memcpy (staging, p, pcursor - p);
+ replace_string_range (result, start1,
+ make_int (starting1),
+ staging, staging + (pcursor - p));
+ }
+ }
+ else
+ {
+ Elemcount seq_len = XINT (Flength (sequence2)), ii = 0,
+ subseq_len = min (min (ending1 - starting1, seq_len - starting1),
+ min (ending2 - starting2, seq_len - starting2));
+ Lisp_Object *subsequence = alloca_array (Lisp_Object, subseq_len);
+
+ check_sequence_range (sequence1, start1, end1, make_int (seq_len));
+ check_sequence_range (sequence2, start2, end2, make_int (seq_len));
+
+ while (starting2 < ending2 && ii < seq_len)
+ {
+ subsequence[ii] = Faref (sequence2, make_int (starting2));
+ ii++, starting2++;
+ }
+
+ ii = 0;
+
+ while (starting1 < ending1 && ii < seq_len)
+ {
+ Faset (sequence1, make_int (starting1), subsequence[ii]);
+ ii++, starting1++;
+ }
+ }
+ }
+ else if (sequence1_listp && sequence2_listp)
+ {
+ Lisp_Object sequence1_tortoise = sequence1,
+ sequence2_tortoise = sequence2;
+ Elemcount shortest_len = 0;
+
+ counting = startcounting = min (ending1, ending2);
+
+ while (counting-- > 0 && !NILP (sequence1) && !NILP (sequence2))
+ {
+ XSETCAR (sequence1,
+ CONSP (sequence2) ? XCAR (sequence2)
+: Fcar (sequence2));
+ sequence1 = CONSP (sequence1) ? XCDR (sequence1)
+: Fcdr (sequence1);
+ sequence2 = CONSP (sequence2) ? XCDR (sequence2)
+: Fcdr (sequence2);
+
+ shortest_len++;
+
+ if (startcounting - counting > CIRCULAR_LIST_SUSPICION_LENGTH)
+ {
+ if (counting & 1)
+ {
+ sequence1_tortoise = XCDR (sequence1_tortoise);
+ sequence2_tortoise = XCDR (sequence2_tortoise);
+ }
+
+ if (EQ (sequence1, sequence1_tortoise))
+ {
+ signal_circular_list_error (sequence1);
+ }
+
+ if (EQ (sequence2, sequence2_tortoise))
+ {
+ signal_circular_list_error (sequence2);
+ }
+ }
+ }
+
+ if (NILP (sequence1))
+ {
+ check_sequence_range (sequence1, start1, end1,
+ make_int (XINT (start1) + shortest_len));
+ }
+ else if (NILP (sequence2))
+ {
+ check_sequence_range (sequence2, start2, end2,
+ make_int (XINT (start2) + shortest_len));
+ }
+ }
+ else if (sequence1_listp)
+ {
+ if (STRINGP (sequence2))
+ {
+ Ibyte *s2_data = XSTRING_DATA (sequence2),
+ *s2_end = s2_data + XSTRING_LENGTH (sequence2);
+ Elemcount char_count = 0;
+ Lisp_Object character;
+
+ while (char_count < starting2 && s2_data < s2_end)
+ {
+ INC_IBYTEPTR (s2_data);
+ char_count++;
+ }
+
+ while (starting1 < ending1 && starting2 < ending2
+ && s2_data < s2_end && !NILP (sequence1))
+ {
+ character = make_char (itext_ichar (s2_data));
+ CONSP (sequence1) ?
+ XSETCAR (sequence1, character)
+: Fsetcar (sequence1, character);
+ sequence1 = XCDR (sequence1);
+ starting1++;
+ starting2++;
+ char_count++;
+ INC_IBYTEPTR (s2_data);
+ }
+
+ if (NILP (sequence1))
+ {
+ check_sequence_range (sequence1, start1, end1,
+ make_int (XINT (start1) + starting1));
+ }
+
+ if (s2_data == s2_end)
+ {
+ check_sequence_range (sequence2, start2, end2,
+ make_int (char_count));
+ }
+ }
+ else
+ {
+ Elemcount len2 = XINT (Flength (sequence2));
+ check_sequence_range (sequence2, start2, end2, make_int (len2));
+
+ ending2 = min (ending2, len2);
+ while (starting2 < ending2
+ && starting1 < ending1 && !NILP (sequence1))
+ {
+ CHECK_CONS (sequence1);
+ XSETCAR (sequence1, Faref (sequence2, make_int (starting2)));
+ sequence1 = XCDR (sequence1);
+ starting1++;
+ starting2++;
+ }
+
+ if (NILP (sequence1))
+ {
+ check_sequence_range (sequence1, start1, end1,
+ make_int (XINT (start1) + starting1));
+ }
+ }
+ }
+ else if (sequence2_listp)
+ {
+ if (STRINGP (sequence1))
+ {
+ Elemcount ii = 0, count, len = string_char_length (sequence1);
+ Ibyte *staging, *cursor;
+ Lisp_Object obj;
+
+ check_sequence_range (sequence1, start1, end1, make_int (len));
+ ending1 = min (ending1, len);
+ count = ending1 - starting1;
+ staging = cursor = alloca_ibytes (count * MAX_ICHAR_LEN);
+
+ while (ii < count && !NILP (sequence2))
+ {
+ obj = CONSP (sequence2) ? XCAR (sequence2)
+: Fcar (sequence2);
+
+ CHECK_CHAR_COERCE_INT (obj);
+ cursor += set_itext_ichar (cursor, XCHAR (obj));
+ ii++;
+ sequence2 = XCDR (sequence2);
+ }
+
+ if (NILP (sequence2))
+ {
+ check_sequence_range (sequence2, start2, end2,
+ make_int (XINT (start2) + ii));
+ }
+
+ replace_string_range (result, start1, make_int (XINT (start1) + ii),
+ staging, cursor);
+ }
+ else
+ {
+ Elemcount len = XINT (Flength (sequence1));
+
+ check_sequence_range (sequence1, start2, end1, make_int (len));
+ ending1 = min (ending2, min (ending1, len));
+
+ while (starting1 < ending1 && !NILP (sequence2))
+ {
+ Faset (sequence1, make_int (starting1),
+ CONSP (sequence2) ? XCAR (sequence2)
+: Fcar (sequence2));
+ sequence2 = XCDR (sequence2);
+ starting1++;
+ starting2++;
+ }
+
+ if (NILP (sequence2))
+ {
+ check_sequence_range (sequence2, start2, end2,
+ make_int (XINT (start2) + starting2));
+ }
+ }
+ }
+ else
+ {
+ if (STRINGP (sequence1) && STRINGP (sequence2))
+ {
+ Ibyte *p2 = XSTRING_DATA (sequence2),
+ *p2end = p2 + XSTRING_LENGTH (sequence2), *p2cursor;
+ Charcount ii = 0, len1 = string_char_length (sequence1);
+
+ while (ii < starting2 && p2 < p2end)
+ {
+ INC_IBYTEPTR (p2);
+ ii++;
+ }
+
+ p2cursor = p2;
+ ending1 = min (ending1, len1);
+
+ while (ii < ending2 && starting1 < ending1 && p2cursor < p2end)
+ {
+ INC_IBYTEPTR (p2cursor);
+ ii++;
+ starting1++;
+ }
+
+ if (p2cursor == p2end)
+ {
+ check_sequence_range (sequence2, start2, end2, make_int (ii));
+ }
+
+ /* This isn't great; any error message won't necessarily reflect
+ the END1 that was supplied to #'replace. */
+ replace_string_range (result, start1, make_int (starting1),
+ p2, p2cursor);
+ }
+ else if (STRINGP (sequence1))
+ {
+ Ibyte *staging, *cursor;
+ Elemcount count, len1 = string_char_length (sequence1);
+ Elemcount len2 = XINT (Flength (sequence2)), ii = 0;;
+ Lisp_Object obj;
+
+ check_sequence_range (sequence1, start1, end1, make_int (len1));
+ check_sequence_range (sequence2, start2, end2, make_int (len2));
+
+ ending1 = min (ending1, len1);
+ ending2 = min (ending2, len2);
+ count = min (ending1 - starting1, ending2 - starting2);
+ staging = cursor = alloca_ibytes (count * MAX_ICHAR_LEN);
+
+ ii = 0;
+ while (ii < count)
+ {
+ obj = Faref (sequence2, make_int (starting2));
+
+ CHECK_CHAR_COERCE_INT (obj);
+ cursor += set_itext_ichar (cursor, XCHAR (obj));
+ starting2++, ii++;
+ }
+
+ replace_string_range (result, start1,
+ make_int (XINT (start1) + count),
+ staging, cursor);
+ }
+ else if (STRINGP (sequence2))
+ {
+ Ibyte *p2 = XSTRING_DATA (sequence2),
+ *p2end = p2 + XSTRING_LENGTH (sequence2);
+ Elemcount len1 = XINT (Flength (sequence1)), ii = 0;
+
+ check_sequence_range (sequence1, start1, end1, make_int (len1));
+ ending1 = min (ending1, len1);
+
+ while (ii < starting2 && p2 < p2end)
+ {
+ INC_IBYTEPTR (p2);
+ ii++;
+ }
+
+ while (p2 < p2end && starting1 < ending1 && starting2 < ending2)
+ {
+ Faset (sequence1, make_int (starting1),
+ make_char (itext_ichar (p2)));
+ INC_IBYTEPTR (p2);
+ starting1++;
+ starting2++;
+ ii++;
+ }
+
+ if (p2 == p2end)
+ {
+ check_sequence_range (sequence2, start2, end2, make_int (ii));
+ }
+ }
+ else
+ {
+ Elemcount len1 = XINT (Flength (sequence1)),
+ len2 = XINT (Flength (sequence2));
+
+ check_sequence_range (sequence1, start1, end1, make_int (len1));
+ check_sequence_range (sequence2, start2, end2, make_int (len2));
+
+ ending1 = min (ending1, len1);
+ ending2 = min (ending2, len2);
+
+ while (starting1 < ending1 && starting2 < ending2)
+ {
+ Faset (sequence1, make_int (starting1),
+ Faref (sequence2, make_int (starting2)));
+ starting1++;
+ starting2++;
+ }
+ }
+ }
+
+ return result;
+}
Lisp_Object
add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string)
＠＠ -5947,6 +6585,7 ＠＠
DEFSYMBOL (Qbit_vector);
defsymbol (&QsortX, "sort*");
DEFSYMBOL (Qreduce);
+ DEFSYMBOL (Qreplace);
DEFSYMBOL (Qmapconcat);
defsymbol (&QmapcarX, "mapcar*");
＠＠ -5963,6 +6602,10 ＠＠
DEFKEYWORD (Q_from_end);
DEFKEYWORD (Q_initial_value);
+ DEFKEYWORD (Q_start1);
+ DEFKEYWORD (Q_start2);
+ DEFKEYWORD (Q_end1);
+ DEFKEYWORD (Q_end2);
DEFSYMBOL (Qyes_or_no_p);
＠＠ -6062,6 +6705,7 ＠＠
DEFSUBR (Freduce);
DEFSUBR (Freplace_list);
+ DEFSUBR (Freplace);
DEFSUBR (Fload_average);
DEFSUBR (Ffeaturep);
DEFSUBR (Frequire);
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Add support for the X11 dead-stroke in x-compose.el.
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5316:dceee3855f15
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Sep 05 20:31:05 2010 +0100
files: lisp/ChangeLog lisp/x-compose.el lisp/x-init.el
description:
Add support for the X11 dead-stroke in x-compose.el.
2010-09-05 Aidan Kehoe <kehoea(a)parhasard.net>
* x-compose.el (define-compose-map, compose-map)
(decide-on-bindings): Support the precomposed characters with
stroke here too, necessary for Polish and Danish, among others.
* x-init.el (x-initialize-compose): Add the appropriate map
autoloads and bindings here.
diff -r 02c282ae97cb -r dceee3855f15 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Sep 05 20:12:53 2010 +0100
+++ b/lisp/ChangeLog Sun Sep 05 20:31:05 2010 +0100
＠＠ -1,3 +1,11 ＠＠
+2010-09-05 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * x-compose.el (define-compose-map, compose-map)
+ (decide-on-bindings): Support the precomposed characters with
+ stroke here too, necessary for Polish and Danish, among others.
+ * x-init.el (x-initialize-compose): Add the appropriate map
+ autoloads and bindings here.
+
2010-09-03 Aidan Kehoe <kehoea(a)parhasard.net>
* cl-extra.el (coerce):
diff -r 02c282ae97cb -r dceee3855f15 lisp/x-compose.el
--- a/lisp/x-compose.el Sun Sep 05 20:12:53 2010 +0100
+++ b/lisp/x-compose.el Sun Sep 05 20:31:05 2010 +0100
＠＠ -156,7 +156,7 ＠＠
compose-cedilla-map compose-diaeresis-map compose-circumflex-map
compose-tilde-map compose-ring-map compose-caron-map compose-macron-map
compose-breve-map compose-dot-map compose-doubleacute-map
- compose-ogonek-map compose-hook-map compose-horn-map))
+ compose-ogonek-map compose-hook-map compose-horn-map compose-stroke-map))
(define-key compose-map 'acute compose-acute-map)
(define-key compose-map 'grave compose-grave-map)
＠＠ -171,6 +171,7 ＠＠
(define-key compose-map 'ogonek compose-ogonek-map)
(define-key compose-map 'breve compose-breve-map)
(define-key compose-map 'abovedot compose-dot-map)
+(define-key compose-map 'stroke compose-stroke-map)
;;(define-key function-key-map [multi-key] compose-map)
＠＠ -195,6 +196,7 ＠＠
(define-key compose-map [~] compose-tilde-map)
(define-key compose-map [degree] compose-ring-map)
(define-key compose-map [?*] compose-ring-map)
+(define-key compose-map [stroke] compose-stroke-map)
(loop
for (keysym character-code map)
＠＠ -564,7 +566,42 ＠＠
(compose-horn-map [?O] #x01A0) ;; CAPITAL O WITH HORN
(compose-horn-map [?U] #x01AF) ;; CAPITAL U WITH HORN
(compose-horn-map [?o] #x01A1) ;; SMALL O WITH HORN
- (compose-horn-map [?u] #x01B0))) ;; SMALL U WITH HORN
+ (compose-horn-map [?u] #x01B0) ;; SMALL U WITH HORN
+ (compose-stroke-map [?A] #x023a) ;; CAPITAL A WITH STROKE
+ (compose-stroke-map [?a] #x2c65) ;; SMALL A WITH STROKE
+ (compose-stroke-map [?B] #x0243) ;; CAPITAL B WITH STROKE
+ (compose-stroke-map [?b] #x0180) ;; SMALL B WITH STROKE
+ (compose-stroke-map [?C] #x023b) ;; CAPITAL C WITH STROKE
+ (compose-stroke-map [?c] #x023c) ;; SMALL C WITH STROKE
+ (compose-stroke-map [?D] #x0110) ;; CAPITAL D WITH STROKE
+ (compose-stroke-map [?d] #x0111) ;; SMALL D WITH STROKE
+ (compose-stroke-map [?E] #x0246) ;; CAPITAL E WITH STROKE
+ (compose-stroke-map [?e] #x0247) ;; SMALL E WITH STROKE
+ (compose-stroke-map [?G] #x01e4) ;; CAPITAL G WITH STROKE
+ (compose-stroke-map [?g] #x01e5) ;; SMALL G WITH STROKE
+ (compose-stroke-map [?H] #x0126) ;; CAPITAL H WITH STROKE
+ (compose-stroke-map [?h] #x0127) ;; SMALL H WITH STROKE
+ (compose-stroke-map [?I] #x0197) ;; CAPITAL I WITH STROKE
+ (compose-stroke-map [?i] #x0268) ;; SMALL I WITH STROKE
+ (compose-stroke-map [?J] #x0248) ;; CAPITAL J WITH STROKE
+ (compose-stroke-map [?j] #x0249) ;; SMALL J WITH STROKE
+ (compose-stroke-map [?K] #xa740) ;; CAPITAL K WITH STROKE
+ (compose-stroke-map [?k] #xa741) ;; SMALL K WITH STROKE
+ (compose-stroke-map [?L] #x0141) ;; CAPITAL L WITH STROKE
+ (compose-stroke-map [?l] #x0142) ;; SMALL L WITH STROKE
+ (compose-stroke-map [?O] #x00d8) ;; CAPITAL O WITH STROKE
+ (compose-stroke-map [?o] #x00f8) ;; SMALL O WITH STROKE
+ (compose-stroke-map [?P] #x2c63) ;; CAPITAL P WITH STROKE
+ (compose-stroke-map [?p] #x1d7d) ;; SMALL P WITH STROKE
+ (compose-stroke-map [?R] #x024c) ;; CAPITAL R WITH STROKE
+ (compose-stroke-map [?r] #x024d) ;; SMALL R WITH STROKE
+ (compose-stroke-map [?T] #x0166) ;; CAPITAL T WITH STROKE
+ (compose-stroke-map [?t] #x0167) ;; SMALL T WITH STROKE
+ (compose-stroke-map [?Y] #x024e) ;; CAPITAL Y WITH STROKE
+ (compose-stroke-map [?y] #x024f) ;; SMALL Y WITH STROKE
+ (compose-stroke-map [?Z] #x01b5) ;; CAPITAL Z WITH STROKE
+ (compose-stroke-map [?z] #x01b6) ;; SMALL Z WITH STROKE
+))
;;; The rest of the compose-map. These are the composed characters
diff -r 02c282ae97cb -r dceee3855f15 lisp/x-init.el
--- a/lisp/x-init.el Sun Sep 05 20:12:53 2010 +0100
+++ b/lisp/x-init.el Sun Sep 05 20:31:05 2010 +0100
＠＠ -92,7 +92,7 ＠＠
compose-ring-map compose-caron-map compose-macron-map
compose-breve-map compose-dot-map
compose-doubleacute-map compose-ogonek-map
- compose-hook-map compose-horn-map)
+ compose-hook-map compose-horn-map compose-stroke-map)
do (autoload map "x-compose" nil t 'keymap))
(loop
＠＠ -208,7 +208,8 ＠＠
(dead-doubleacute compose-doubleacute-map)
(dead-ogonek compose-ogonek-map)
(dead-hook compose-hook-map)
- (dead-horn compose-horn-map))
+ (dead-horn compose-horn-map)
+ (dead-stroke compose-stroke-map))
;; Get the correct value for function-key-map
with function-key-map = (symbol-value-in-console 'function-key-map
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
carbon2-commit: Read and print char table defaults, chartab.c
14 years, 1 month
Aidan Kehoe
Aidan Kehoe
changeset: 5315:02c282ae97cb
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Sep 05 20:12:53 2010 +0100
files: src/ChangeLog src/chartab.c
description:
Read and print char table defaults, chartab.c
2010-09-05 Aidan Kehoe <kehoea(a)parhasard.net>
* chartab.c (char_table_default_for_type,
chartab_default_validate): New.
(print_char_table, Freset_char_table, chartab_default_validate)
(chartab_instantiate, structure_type_create_chartab):
Accept keyword :default in the read syntax for char tables, and
print the default when it is not what was expected for the
time. Makes it a little easier to debug things.
diff -r 1ed4cefddd12 -r 02c282ae97cb src/ChangeLog
--- a/src/ChangeLog Sun Sep 05 19:22:37 2010 +0100
+++ b/src/ChangeLog Sun Sep 05 20:12:53 2010 +0100
＠＠ -1,3 +1,13 ＠＠
+2010-09-05 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * chartab.c (char_table_default_for_type,
+ chartab_default_validate): New.
+ (print_char_table, Freset_char_table, chartab_default_validate)
+ (chartab_instantiate, structure_type_create_chartab):
+ Accept keyword :default in the read syntax for char tables, and
+ print the default when it is not what was expected for the
+ time. Makes it a little easier to debug things.
+
2010-09-05 Aidan Kehoe <kehoea(a)parhasard.net>
* editfns.c (Fformat_time_string):
diff -r 1ed4cefddd12 -r 02c282ae97cb src/chartab.c
--- a/src/chartab.c Sun Sep 05 19:22:37 2010 +0100
+++ b/src/chartab.c Sun Sep 05 20:12:53 2010 +0100
＠＠ -42,7 +42,7 ＠＠
#include "chartab.h"
#include "syntax.h"
-Lisp_Object Qchar_tablep, Qchar_table;
+Lisp_Object Qchar_tablep, Qchar_table, Q_default;
Lisp_Object Vall_syntax_tables;
＠＠ -301,6 +301,30 ＠＠
return Qnil; /* not reached */
}
+static Lisp_Object
+char_table_default_for_type (enum char_table_type type)
+{
+ switch (type)
+ {
+ case CHAR_TABLE_TYPE_CHAR:
+ return make_char (0);
+ break;
+ case CHAR_TABLE_TYPE_DISPLAY:
+ case CHAR_TABLE_TYPE_GENERIC:
+#ifdef MULE
+ case CHAR_TABLE_TYPE_CATEGORY:
+#endif /* MULE */
+ return Qnil;
+ break;
+
+ case CHAR_TABLE_TYPE_SYNTAX:
+ return make_integer (Sinherit);
+ break;
+ }
+ ABORT();
+ return Qzero;
+}
+
struct ptemap
{
Lisp_Object printcharfun;
＠＠ -336,8 +360,15 ＠＠
arg.printcharfun = printcharfun;
arg.first = 1;
- write_fmt_string_lisp (printcharfun, "#s(char-table :type %s :data (",
- 1, char_table_type_to_symbol (ct->type));
+ write_fmt_string_lisp (printcharfun,
+ "#s(char-table :type %s", 1,
+ char_table_type_to_symbol (ct->type));
+ if (!(EQ (ct->default_, char_table_default_for_type (ct->type))))
+ {
+ write_fmt_string_lisp (printcharfun, " :default %S", 1, ct->default_);
+ }
+
+ write_ascstring (printcharfun, " :data (");
map_char_table (obj, &range, print_table_entry, &arg);
write_ascstring (printcharfun, "))");
＠＠ -492,37 +523,13 ＠＠
(char_table))
{
Lisp_Char_Table *ct;
- Lisp_Object def;
CHECK_CHAR_TABLE (char_table);
ct = XCHAR_TABLE (char_table);
- switch (ct->type)
- {
- case CHAR_TABLE_TYPE_CHAR:
- def = make_char (0);
- break;
- case CHAR_TABLE_TYPE_DISPLAY:
- case CHAR_TABLE_TYPE_GENERIC:
-#ifdef MULE
- case CHAR_TABLE_TYPE_CATEGORY:
-#endif /* MULE */
- def = Qnil;
- break;
-
- case CHAR_TABLE_TYPE_SYNTAX:
- def = make_int (Sinherit);
- break;
-
- default:
- ABORT ();
- def = Qnil;
- break;
- }
-
/* Avoid doubly updating the syntax table by setting the default ourselves,
since set_char_table_default() also updates. */
- ct->default_ = def;
+ ct->default_ = char_table_default_for_type (ct->type);
fill_char_table (ct, Qunbound);
return Qnil;
＠＠ -1543,12 +1550,22 ＠＠
return 1;
}
+static int
+chartab_default_validate (Lisp_Object UNUSED (keyword),
+ Lisp_Object UNUSED (value),
+ Error_Behavior UNUSED (errb))
+{
+ /* We can't yet validate this, since we don't know what the type of the
+ char table is. We do the validation below in chartab_instantiate(). */
+ return 1;
+}
+
static Lisp_Object
chartab_instantiate (Lisp_Object plist)
{
Lisp_Object chartab;
Lisp_Object type = Qgeneric;
- Lisp_Object dataval = Qnil;
+ Lisp_Object dataval = Qnil, default_ = Qunbound;
if (KEYWORDP (Fcar (plist)))
{
＠＠ -1561,6 +1578,10 ＠＠
else if (EQ (key, Q_type))
{
type = value;
+ }
+ else if (EQ (key, Q_default))
+ {
+ default_ = value;
}
else if (!KEYWORDP (key))
{
＠＠ -1598,6 +1619,13 ＠＠
#endif /* NEED_TO_HANDLE_21_4_CODE */
chartab = Fmake_char_table (type);
+ if (!UNBOUNDP (default_))
+ {
+ check_valid_char_table_value (default_, XCHAR_TABLE_TYPE (chartab),
+ ERROR_ME);
+ set_char_table_default (chartab, default_);
+ set_char_table_default (XCHAR_TABLE (chartab)->mirror_table, default_);
+ }
while (!NILP (dataval))
{
＠＠ -1872,6 +1900,7 ＠＠
DEFSYMBOL (Qchar_table);
DEFSYMBOL_MULTIWORD_PREDICATE (Qchar_tablep);
+ DEFKEYWORD (Q_default);
DEFSUBR (Fchar_table_p);
DEFSUBR (Fchar_table_type_list);
＠＠ -1926,6 +1955,7 ＠＠
define_structure_type_keyword (st, Q_type, chartab_type_validate);
define_structure_type_keyword (st, Q_data, chartab_data_validate);
+ define_structure_type_keyword (st, Q_default, chartab_default_validate);
}
void
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments