Mercurial > hg > xemacs-beta
changeset 5671:f45338de7caa
Merge in my release prep stuff.
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Fri, 03 Aug 2012 02:05:08 +0900 |
| parents | baab2e3a4141 (current diff) ee95ef1e644c (diff) |
| children | 7c3e44003e0f |
| files | |
| diffstat | 61 files changed, 3352 insertions(+), 1715 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/ChangeLog Fri Aug 03 02:05:08 2012 +0900 @@ -1,3 +1,362 @@ +2012-05-14 Aidan Kehoe <kehoea@parhasard.net> + + * byte-optimize.el (byte-optimize-letX): + In (let ...) forms, group constant initialisations together, so we + can just dup in the byte code. + +2012-05-14 Aidan Kehoe <kehoea@parhasard.net> + + Update minibuf.el to use #'test-completion, use the generality of + recent completion changes to avoid some unnecessary consing when + reading. + * behavior.el (read-behavior): + * cus-edit.el (custom-face-prompt): + * cus-edit.el (widget-face-action): + * faces.el (read-face-name): + * minibuf.el: + * minibuf.el (minibuffer-completion-table): + * minibuf.el (exact-minibuffer-completion-p): + Removed. #'test-completion is equivalent to this, but more + general. + * minibuf.el (minibuffer-do-completion-1): Use #'test-completion. + * minibuf.el (completing-read): Update the documentation of the + arguments used for completion. + * minibuf.el (minibuffer-complete-and-exit): Use #'test-completion. + * minibuf.el (exit-minibuffer): Use #'test-completion. + * minibuf.el (minibuffer-smart-mouse-tracker): Use #'test-completion. + * minibuf.el (read-color): No need to construct a completion table + separate from the colour list. + +2012-05-12 Aidan Kehoe <kehoea@parhasard.net> + + * subr.el: + * subr.el (truncate-string-to-width): + Sync with GNU's version, use its test suite in mule-tests.el. + Avoid args-out-of-range errors, this function is regularly called + from menu code and with debug-on-signal non-nil, this can be very + irritating. + Don't bind ellipsis-len, we don't use it. + +2012-05-12 Aidan Kehoe <kehoea@parhasard.net> + + * byte-optimize.el (byte-compile-unfold-lambda): + Fetch the bytecode before unfolding a compiled function, its body + may have been compiled lazily thanks to + byte-compile-dynamic. Thank you Mats Lidell and the package + smoketest! + +2012-05-10 Aidan Kehoe <kehoea@parhasard.net> + + * mule/mule-category.el (word-combining-categories): + Be better about default word boundaries when text contains + just-in-time-allocated Unicode code points. Document what we + should do instead once we have Unicode internally. + * mule/misc-lang.el: IPA characters are Latin. + +2012-05-08 Aidan Kehoe <kehoea@parhasard.net> + + * cl-macs.el (rassoc): Remove a stray parenthesis here, thank you + Vin! + +2012-05-06 Aidan Kehoe <kehoea@parhasard.net> + + * cl-macs.el (block): Comment on why we can't use &environment + here. + * cl-macs.el (defmacro*): Document &environment in more detail. + * cl-macs.el (macrolet): Use &environment, instead of referencing + byte-compile-macro-environment directly. + * cl-macs.el (symbol-macrolet): Ditto. + * cl-macs.el (lexical-let): Ditto. + * cl-macs.el (labels): Ditto. + +2012-05-06 Aidan Kehoe <kehoea@parhasard.net> + + * byte-optimize.el: + * byte-optimize.el (or): + * byte-optimize.el (byte-optimize-or): + Declare for-effect properly, it's not free. + * byte-optimize.el (byte-optimize-condition-case): New. + * byte-optimize.el (byte-optimize-form-code-walker): + Be more exhaustive in descending special forms, for the sake of + lexically-oriented optimizers such as that for #'labels. + +2012-05-05 Aidan Kehoe <kehoea@parhasard.net> + + Co-operate with the byte-optimizer in the bytecomp.el labels + implementation, don't work against it. + + * byte-optimize.el: + * byte-optimize.el (byte-compile-inline-expand): + Call #'byte-compile-unfold-lambda explicitly here, don't assume + that the byte-optimizer will do it. + * byte-optimize.el (byte-compile-unfold-lambda): + Call #'byte-optimize-body on the body, don't just mapcar + #'byte-optimize-form along it. + * byte-optimize.el (byte-optimize-lambda): New. Optimize a lambda + form. + * byte-optimize.el (byte-optimize-form-code-walker): + Descend lambda expressions, defun, and defmacro, relevant for + lexically-oriented operators like #'labels. + * byte-optimize.el (byte-optimize-body): Only return a non-eq + object if we've actually optimized something + * bytecomp.el (byte-compile-initial-macro-environment): + In the labels implementation, work with the byte optimizer, not + against it; warn when labels are defined but not used, + automatically inline labels that are used only once. + * bytecomp.el (byte-recompile-directory): + No need to wrap #'byte-compile-report-error in a lambda with + #'call-with-condition-handler here. + * bytecomp.el (byte-compile-form): + Don't inline compiled-function objects, they're probably labels. + * bytecomp.el (byte-compile-funcall): + No longer inline lambdas, trust the byte optimizer to have done it + properly, even for labels. + * cl-extra.el (cl-macroexpand-all): + Treat labels established by the byte compiler distinctly from + those established by cl-macs.el. + * cl-macs.el (cl-do-proclaim): + Treat labels established by the byte compiler distinctly from + those established by cl-macs.el. + * gui.el (make-gui-button): + When referring to the #'gui-button-action label, quote it using + function, otherwise there's a warning from the byte compiler. + +2012-05-05 Aidan Kehoe <kehoea@parhasard.net> + + Remove some redundant functions; turn other utility functions into + labels, avoiding visibility in the global namespace, and reducing + the size of the dumped binary. + + * auto-save.el (auto-save-unhex): Removed. + * auto-save.el (auto-save-unescape-name): Use #'string-to-number + instead of #'auto-save-unhex. + * files.el (save-some-buffers): + * files.el (save-some-buffers-1): Changed to a label. + * files.el (not-modified): + * gui.el (make-gui-button): + * gui.el (gui-button-action): Changed to a label. + * gui.el (insert-gui-button): + * indent.el (indent-for-tab-command): + * indent.el (insert-tab): Changed to a label. + * indent.el (indent-rigidly): + * isearch-mode.el: + * isearch-mode.el (isearch-ring-adjust): + * isearch-mode.el (isearch-ring-adjust1): Changed to a label. + * isearch-mode.el (isearch-pre-command-hook): + * isearch-mode.el (isearch-maybe-frob-keyboard-macros): Changed to + a label. + * isearch-mode.el (isearch-highlight): + * isearch-mode.el (isearch-make-extent): Changed to a label. + * itimer.el: + * itimer.el (itimer-decrement): Removed, replaced uses with decf. + * itimer.el (itimer-increment): Removed, replaced uses with incf. + * itimer.el (itimer-signum): Removed, replaced uses with minusp, plusp. + * itimer.el (itimer-name): + * itimer.el (check-itimer): Removed, replaced with #'check-type calls. + * itimer.el (itimer-value): + * itimer.el (check-itimer-coerce-string): Removed. + * itimer.el (itimer-restart): + * itimer.el (itimer-function): + * itimer.el (check-nonnegative-number): Removed. + * itimer.el (itimer-uses-arguments): + * itimer.el (check-string): Removed. + * itimer.el (itimer-function-arguments): + * itimer.el (itimer-recorded-run-time): + * itimer.el (set-itimer-name): + * itimer.el (set-itimer-value): + * itimer.el (set-itimer-value-internal): + * itimer.el (set-itimer-restart): + * itimer.el (set-itimer-function): + * itimer.el (set-itimer-is-idle): + * itimer.el (set-itimer-recorded-run-time): + * itimer.el (get-itimer): + * itimer.el (delete-itimer): + * itimer.el (start-itimer): + * itimer.el (activate-itimer): + * itimer.el (itimer-edit-set-field): + * itimer.el (itimer-edit-next-field): + * itimer.el (itimer-edit-previous-field): + Use incf, decf, plusp, minusp and the more general argument type + checking macros. + * lib-complete.el: + * lib-complete.el (lib-complete:better-root): Changed to a label. + * lib-complete.el (lib-complete:get-completion-table): Changed to + a label. + * lib-complete.el (read-library-internal): Include labels. + * lib-complete.el (lib-complete:cache-completions): Changed to a + label. + * minibuf.el (read-buffer): Use #'set-difference, don't reinvent it. + * newcomment.el (comment-padright): Use a label instead of + repeating a lambda expression. + * packages.el (package-get-key): + * packages.el (package-get-key-1): Removed, use #'getf instead. + * simple.el (kill-backward-chars): Removed; this isn't used. + * simple.el (what-cursor-position): + (lambda (arg) (format "%S" arg) -> #'prin1-to-string. + * simple.el (debug-print-1): Renamed to #'debug-print. + * simple.el (debug-print): Removed, #'debug-print-1 was equivalent. + * subr.el (integer-to-bit-vector): check-nonnegative-number no + longer available. + * widget.el (define-widget): + * widget.el (define-widget-keywords): Removed, this was long obsolete. + +2012-05-01 Aidan Kehoe <kehoea@parhasard.net> + + Avoid #'delq in core code, for the sake of style and a (very + slightly) smaller binary. + + * behavior.el (disable-behavior): + * behavior.el (compute-behavior-group-children): + * buff-menu.el (buffers-tab-items): + * byte-optimize.el (byte-optimize-delay-constants-math): + * byte-optimize.el (byte-optimize-logmumble): + * byte-optimize.el (byte-decompile-bytecode-1): + * byte-optimize.el (byte-optimize-lapcode): + * bytecomp.el: + * bytecomp.el (byte-compile-arglist-warn): + * bytecomp.el (byte-compile-warn-about-unresolved-functions): + * bytecomp.el (byte-compile-lambda): + * bytecomp.el (byte-compile-out-toplevel): + * bytecomp.el (byte-compile-insert): + * bytecomp.el (byte-compile-defalias-warn): + * cl-macs.el (cl-upcase-arg): + * cl-macs.el (cl-transform-lambda): + * cl-macs.el (cl-do-proclaim): + * cl-macs.el (defstruct): + * cl-macs.el (cl-make-type-test): + * cl-macs.el (define-compiler-macro): + * cl-macs.el (delete-duplicates): + * cus-edit.el (widget-face-value-delete): + * cus-edit.el (face-history): + * easymenu.el (easy-menu-remove): + * files.el (files-fetch-hook-value): + * files.el (file-expand-wildcards): + * font-lock.el (font-lock-update-removed-keyword-alist): + * font-lock.el (font-lock-remove-keywords): + * frame.el (frame-initialize): + * frame.el (frame-notice-user-settings): + * frame.el (set-frame-font): + * frame.el (delete-other-frames): + * frame.el (get-frame-for-buffer-noselect): + * gnuserv.el (gnuserv-kill-buffer-function): + * gnuserv.el (gnuserv-check-device): + * gnuserv.el (gnuserv-kill-client): + * gnuserv.el (gnuserv-buffer-done-1): + * gtk-font-menu.el (gtk-reset-device-font-menus): + * gutter-items.el (buffers-tab-items): + * gutter.el (set-gutter-element-visible-p): + * info.el (Info-find-file-node): + * info.el (Info-history-add): + * info.el (Info-build-annotation-completions): + * info.el (Info-index): + * info.el (Info-reannotate-node): + * itimer.el (delete-itimer): + * itimer.el (start-itimer): + * lib-complete.el (lib-complete:cache-completions): + * loadhist.el (unload-feature): + * menubar-items.el (build-buffers-menu-internal): + * menubar.el (delete-menu-item): + * menubar.el (relabel-menu-item): + * msw-font-menu.el (mswindows-reset-device-font-menus): + * mule/make-coding-system.el (fixed-width-generate-helper): + * next-error.el (next-error-find-buffer): + * obsolete.el: + * obsolete.el (find-non-ascii-charset-string): + * obsolete.el (find-non-ascii-charset-region): + * occur.el (multi-occur-by-filename-regexp): + * occur.el (occur-1): + * packages.el (packages-package-hierarchy-directory-names): + * packages.el (package-get-key-1): + * process.el (setenv): + * simple.el (undo): + * simple.el (handle-pre-motion-command-current-command-is-motion): + * sound.el (load-sound-file): + * wid-edit.el (widget-field-value-delete): + * wid-edit.el (widget-checklist-match-inline): + * wid-edit.el (widget-checklist-match-find): + * wid-edit.el (widget-editable-list-delete-at): + * wid-edit.el (widget-editable-list-entry-create): + * window.el (quit-window): + * x-font-menu.el (x-reset-device-font-menus-core): + + 1. Replace (delq nil (mapcar ....)) with analogous (mapcan ...) + forms; this is in non-dumped files, it was done previously in + dumped files. + 2. Replace (delq FOO (copy-sequence BAR)) with (remove* FOO BAR), + where #'eq and #'eql are equivalent + 3. Replace (delq FOO BAR) with (delete* FOO BAR), where FOO is not + a non-fixnum number. Saves a little space in the dumped file + (since the compiler macro adds :test #'eq to the delete* call if + it's not clear that FOO is not a non-fixnum number). + +2012-05-07 Aidan Kehoe <kehoea@parhasard.net> + + * cl-macs.el: + * cl-macs.el (cl-non-fixnum-number-p): Rename, to + cl-non-immediate-number-p. This is a little more informative as a + name, though still not ideal, in that it will give t for some + immediate fixnums on 64-bit builds. + * cl-macs.el (eql): + * cl-macs.el (define-star-compiler-macros): + * cl-macs.el (delq): + * cl-macs.el (remq): + Use the new name. + * cl-macs.el (cl-equal-equivalent-to-eq-p): New. + * cl-macs.el (cl-car-or-pi): New. + * cl-macs.el (cl-cdr-or-pi): New. + * cl-macs.el (equal): New compiler macro. + * cl-macs.el (member): New compiler macro. + * cl-macs.el (assoc): New compiler macro. + * cl-macs.el (rassoc): New compiler macro. + If any of #'equal, #'member, #'assoc or #'rassoc has a constant + argument such that #'eq, #'memq, #'assq or #'rassq, respectively, + are equivalent, make the substitution. Relevant in files like + ispell.el, there's a reasonable amount of code out there that + doesn't quite get the distinction. + +2012-05-01 Aidan Kehoe <kehoea@parhasard.net> + + * byte-optimize.el (byte-optimize-form-code-walker): + * byte-optimize.el (byte-optimize-or): + Improve handling of for-effect here; we don't need to worry about + discarding multiple values when for-effect is non-nil, this + applies to both #'prog1 and #'or. + * bytecomp.el (progn): + * bytecomp.el (byte-compile-file-form-progn): New. + Put back this function, since it's for-effect there's no need to + worry about passing back multiple values. + * cl-macs.el (cl-pop2): + * cl-macs.el (cl-do-pop): + * cl-macs.el (remf): + * cl.el (pop): + Expand to (prog1 (car-safe PLACE) (setq PLACE (cdr PLACE))) in all + these macros, since that optimizes better (especially for-effect + handling) when byte-compile-delete-errors is nil. + +2012-04-23 Michael Sperber <mike@xemacs.org> + + * bytecomp.el (batch-byte-recompile-directory): Accept an optional + argument that's passed on to `byte-recompile-directory' as the + prefix argument, thus imitating GNU Emacs's API. + +2012-04-07 Aidan Kehoe <kehoea@parhasard.net> + + Remove some utility functions from the global namespace, it's more + appropriate to have them as labels (that is, lexically-visible + functions.) + * behavior.el: + * behavior.el (behavior-menu-filter-1): Moved to being a label. + * behavior.el (behavior-menu-filter): Use the label. + * cus-edit.el (custom-load-symbol-1): Moved to being a label. + * cus-edit.el (custom-load-symbol): Use the label. + * menubar.el (find-menu-item-1): Moved to being a label. + * menubar.el (find-menu-item): Use the label. + * window-xemacs.el: + * window-xemacs.el (display-buffer-1): Moved to being a label. + * window-xemacs.el (display-buffer): Use the label; use (block + ...) instead of (catch ...), use prog1 instead of needlessly + binding a variable. + 2012-03-02 Aidan Kehoe <kehoea@parhasard.net> * select.el (select-coerce): @@ -4849,6 +5208,12 @@ Bind print-gensym-alist to nil, as we do within byte-compile-output-docform. +2008-01-03 Michael Sperber <mike@xemacs.org> + + * files.el (file-remote-p): Synch with GNU Emac: Add + `identification' and `connected' parameters, and use file-name + handler if available. Zap support for ange-ftp. + 2008-01-04 Michael Sperber <mike@xemacs.org> * code-files.el (insert-file-contents):
--- a/lisp/auto-save.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/auto-save.el Fri Aug 03 02:05:08 2012 +0900 @@ -412,24 +412,15 @@ (char-to-string char)))) str "")) -(defun auto-save-unhex (x) - (if (> x ?9) - (if (>= x ?a) - (+ 10 (- x ?a)) - (+ 10 (- x ?A))) - (- x ?0))) - (defun auto-save-unescape-name (str) "Undo any escaping of evil nasty characters in a file name. See `auto-save-escape-name'." (setq str (or str "")) (let ((tmp "") (case-fold-search t)) - (while (string-match "=[0-9a-f][0-9a-f]" str) + (while (string-match #r"=\([0-9a-f][0-9a-f]\)" str) (let* ((start (match-beginning 0)) - (ch1 (auto-save-unhex (elt str (+ start 1)))) - (code (+ (* 16 ch1) - (auto-save-unhex (elt str (+ start 2)))))) + (code (string-to-number (match-string 1 str) 16))) (setq tmp (concat tmp (substring str 0 start) (char-to-string code)) str (substring str (match-end 0)))))
--- a/lisp/behavior.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/behavior.el Fri Aug 03 02:05:08 2012 +0900 @@ -345,16 +345,10 @@ for history command, and as the value to return if the user enters the empty string." (let ((result - (completing-read - prompt - (let (list) - (maphash #'(lambda (key value) - (push (cons (symbol-name key) value) list)) - behavior-hash-table) - list) - nil must-match initial-contents (or history 'behavior-history) - default-value))) - (if (and result (stringp result)) + (completing-read prompt behavior-hash-table nil must-match + initial-contents (or history 'behavior-history) + default-value))) + (if (stringp result) (intern result) result))) @@ -403,7 +397,7 @@ (message "Disabling behavior %s...done" behavior) (let ((within-behavior-enabling-disabling t)) (customize-set-variable 'enabled-behavior-list - (delq behavior enabled-behavior-list)))))) + (delete* behavior enabled-behavior-list)))))) (defun compute-behavior-group-children (group hash) "Compute the actual children for GROUP and its subgroups. @@ -414,90 +408,96 @@ ) ) -(defun behavior-menu-filter-1 (menu group) - (submenu-generate-accelerator-spec - (let* ( - ;;options - ;;help - (enable - (menu-split-long-menu - (menu-sort-menu - (let ((group-plist (gethash group behavior-group-hash-table))) - (loop for behavior in (getf group-plist :children) - nconc (if (behavior-group-p behavior) - (list - (cons (getf - (gethash behavior behavior-group-hash-table) - :short-doc) - (behavior-menu-filter-1 menu behavior))) - (let* ((plist (gethash behavior behavior-hash-table)) - (commands (getf plist :commands))) - (nconc - (if (getf plist :enable) - `([,(format "%s (%s) [toggle]" - (getf plist :short-doc) - behavior) - (if (memq ',behavior - enabled-behavior-list) - (disable-behavior ',behavior) - (enable-behavior ',behavior)) - :active ,(if (getf plist :disable) t - (not (memq - ',behavior - enabled-behavior-list))) - :style toggle - :selected (memq ',behavior - enabled-behavior-list)])) - (cond ((null commands) nil) - ((and (eq (length commands) 1) - (vectorp (elt commands 0))) - (let ((comm (copy-sequence - (elt commands 0)))) - (setf (elt comm 0) - (format "%s (%s)" - (elt comm 0) behavior)) - (list comm))) - (t (list - (cons (format "%s (%s) Commands" - (getf plist :short-doc) - behavior) - commands))))))))) - )) - ) - ) - enable) - '(?p))) - (defun behavior-menu-filter (menu) - (append - `(("%_Package Utilities" - ("%_Set Download Site" - ("%_Official Releases" - :filter ,#'(lambda (&rest junk) - (menu-split-long-menu - (submenu-generate-accelerator-spec - (package-ui-download-menu))))) - ("%_Pre-Releases" - :filter ,#'(lambda (&rest junk) - (menu-split-long-menu - (submenu-generate-accelerator-spec - (package-ui-pre-release-download-menu))))) - ("%_Site Releases" - :filter ,#'(lambda (&rest junk) - (menu-split-long-menu - (submenu-generate-accelerator-spec - (package-ui-site-release-download-menu)))))) - "--:shadowEtchedIn" - ["%_Update Package Index" package-get-update-base] - ["%_List and Install" pui-list-packages] - ["U%_pdate Installed Packages" package-get-update-all] - ["%_Help" (Info-goto-node "(xemacs)Packages")]) - "----") - (behavior-menu-filter-1 menu nil))) + (labels + ((behavior-menu-filter-1 (menu group) + (submenu-generate-accelerator-spec + (let* ((enable + (menu-split-long-menu + (menu-sort-menu + (let ((group-plist (gethash group + behavior-group-hash-table))) + (loop for behavior in (getf group-plist :children) + nconc (if (behavior-group-p behavior) + (list + (cons (getf + (gethash behavior + behavior-group-hash-table) + :short-doc) + (behavior-menu-filter-1 + menu behavior))) + (let* ((plist (gethash behavior + behavior-hash-table)) + (commands (getf plist :commands))) + (nconc + (if (getf plist :enable) + `([,(format "%s (%s) [toggle]" + (getf plist :short-doc) + behavior) + (if (memq ',behavior + enabled-behavior-list) + (disable-behavior ',behavior) + (enable-behavior ',behavior)) + :active ,(if (getf plist :disable) + t + (not + (memq + ',behavior + enabled-behavior-list))) + :style toggle + :selected (memq + ',behavior + enabled-behavior-list)])) + (cond ((null commands) nil) + ((and (eq (length commands) 1) + (vectorp (elt commands 0))) + (let ((comm (copy-sequence + (elt commands 0)))) + (setf (elt comm 0) + (format "%s (%s)" + (elt comm 0) + behavior)) + (list comm))) + (t (list + (cons (format "%s (%s) Commands" + (getf plist + :short-doc) + behavior) + commands))))))))) + )) + ) + ) + enable) + '(?p)))) + (append + `(("%_Package Utilities" + ("%_Set Download Site" + ("%_Official Releases" + :filter ,#'(lambda (&rest junk) + (menu-split-long-menu + (submenu-generate-accelerator-spec + (package-ui-download-menu))))) + ("%_Pre-Releases" + :filter ,#'(lambda (&rest junk) + (menu-split-long-menu + (submenu-generate-accelerator-spec + (package-ui-pre-release-download-menu))))) + ("%_Site Releases" + :filter ,#'(lambda (&rest junk) + (menu-split-long-menu + (submenu-generate-accelerator-spec + (package-ui-site-release-download-menu)))))) + "--:shadowEtchedIn" + ["%_Update Package Index" package-get-update-base] + ["%_List and Install" pui-list-packages] + ["U%_pdate Installed Packages" package-get-update-all] + ["%_Help" (Info-goto-node "(xemacs)Packages")]) + "----") + (behavior-menu-filter-1 menu nil)))) ;; Initialize top-level group. (puthash nil '(:children nil :short-doc "Root") behavior-group-hash-table) (provide 'behavior) -;;; finder-inf.el ends here +;;; behavior.el ends here
--- a/lisp/buff-menu.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/buff-menu.el Fri Aug 03 02:05:08 2012 +0900 @@ -860,10 +860,10 @@ (not in-deletion) (not (eq first-buf (window-buffer (selected-window frame))))) (setq buffers (cons (window-buffer (selected-window frame)) - (delq first-buf buffers)))) + (delete* first-buf buffers)))) ;; if we're in deletion ignore the current buffer (when in-deletion - (setq buffers (delq (current-buffer) buffers)) + (setq buffers (delete* (current-buffer) buffers)) (setq first-buf (car buffers))) ;; filter buffers (when buffers-tab-filter-functions
--- a/lisp/byte-optimize.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/byte-optimize.el Fri Aug 03 02:05:08 2012 +0900 @@ -284,19 +284,10 @@ (error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name)) (if (symbolp fn) (byte-compile-inline-expand (cons fn (cdr form))) - (if (compiled-function-p fn) - (progn - (fetch-bytecode fn) - (cons (list 'lambda (compiled-function-arglist fn) - (list 'byte-code - (compiled-function-instructions fn) - (compiled-function-constants fn) - (compiled-function-stack-depth fn))) - (cdr form))) - (if (eq (car-safe fn) 'lambda) - (cons fn (cdr form)) - ;; Give up on inlining. - form)))))) + (if (or (eq (car-safe fn) 'lambda) (compiled-function-p fn)) + (byte-compile-unfold-lambda (cons fn (cdr form))) + ;; Give up on inlining. + form))))) ;;; ((lambda ...) ...) ;;; @@ -305,11 +296,12 @@ (let ((lambda (car form)) (values (cdr form))) (if (compiled-function-p lambda) - (setq lambda (list 'lambda (compiled-function-arglist lambda) - (list 'byte-code - (compiled-function-instructions lambda) - (compiled-function-constants lambda) - (compiled-function-stack-depth lambda))))) + (setq lambda (fetch-bytecode lambda) + lambda (list 'lambda (compiled-function-arglist lambda) + (list 'byte-code + (compiled-function-instructions lambda) + (compiled-function-constants lambda) + (compiled-function-stack-depth lambda))))) (let ((arglist (nth 1 lambda)) (body (cdr (cdr lambda))) optionalp restp @@ -354,7 +346,7 @@ (byte-compile-warn "attempt to open-code %s with too many arguments" name)) form) - (setq body (mapcar 'byte-optimize-form body)) + (setq body (byte-optimize-body body nil)) (let ((newform (if bindings (cons 'let (cons (nreverse bindings) body)) @@ -363,6 +355,37 @@ newform))))) +(defun byte-optimize-lambda (form) + (let* ((offset 2) (body (nthcdr offset form))) + (if (stringp (car body)) (setq body (nthcdr (incf offset) form))) + (if (eq 'interactive (car-safe (car body))) + (setq body (nthcdr (incf offset) form))) + (if (eq body (setq body (byte-optimize-body body nil))) + form + (nconc (subseq form 0 offset) body)))) + +;; Setting this to the byte-optimizer property of condition-case gives an +;; infinite loop, as of So 6 Mai 2012 05:10:44 IST +(defun byte-optimize-condition-case (form &optional for-effect) + (let ((modified nil) + (result nil) + (new nil)) + (setq result + (list* (car form) (nth 1 form) + (prog1 + (setq new (byte-optimize-form (nth 2 form) for-effect)) + (setq modified (or modified (eq new (nth 2 form))))) + (mapcar #'(lambda (handler) + (if (eq (cdr handler) + (setq new + (byte-optimize-body (cdr handler) + for-effect))) + handler + (setq modified t) + (cons (car handler) new))) + (cdddr form)))) + (if modified result form))) + ;;; implementing source-level optimizers (defun byte-optimize-form-code-walker (form for-effect) @@ -390,9 +413,19 @@ (and (nth 1 form) (not for-effect) form)) - ((or (compiled-function-p fn) - (eq 'lambda (car-safe fn))) - (byte-compile-unfold-lambda form)) + ((eq fn 'function) + (when (cddr form) + (byte-compile-warn "malformed function form: %S" form)) + (cond + (for-effect nil) + ((and (eq (car-safe (cadr form)) 'lambda) + (not (eq (cadr form) (setq tmp (byte-optimize-lambda + (cadr form)))))) + (list fn tmp)) + (t form))) + ((and (eq 'lambda (car-safe fn)) + (not (eq form (setq form (byte-compile-unfold-lambda form))))) + form) ((memq fn '(let let*)) ;; recursively enter the optimizer for the bindings and body ;; of a let or let*. This for depth-firstness: forms that @@ -431,7 +464,7 @@ (byte-optimize-form (nth 1 form) for-effect))) ((eq fn 'prog1) (if (cdr (cdr form)) - (cons 'prog1 + (cons (if for-effect 'progn 'prog1) (cons (byte-optimize-form (nth 1 form) for-effect) (byte-optimize-body (cdr (cdr form)) t))) (byte-optimize-form `(or ,(nth 1 form) nil) for-effect))) @@ -490,30 +523,35 @@ (prin1-to-string form)) nil) - ((memq fn '(defun defmacro function - condition-case save-window-excursion)) - ;; These forms are compiled as constants or by breaking out - ;; all the subexpressions and compiling them separately. - form) + ((memq fn '(defun defmacro)) + (if (eq (setq tmp (cons 'lambda (cddr form))) + (setq tmp (byte-optimize-lambda tmp))) + form + (nconc (subseq form 0 2) (cdr tmp)))) + + ((eq fn 'condition-case) + (if (eq (setq tmp (byte-optimize-condition-case form for-effect)) + form) + form + tmp)) ((eq fn 'unwind-protect) - ;; the "protected" part of an unwind-protect is compiled (and thus - ;; optimized) as a top-level form, so don't do it here. But the + ;; the "protected" part of an unwind-protect is compiled (and + ;; thus optimized) as a top-level form, but do it here too for + ;; the sake of lexically-oriented code (labels, and so on). The ;; non-protected part has the same for-effect status as the - ;; unwind-protect itself. (The protected part is always for effect, - ;; but that isn't handled properly yet.) + ;; unwind-protect itself. (cons fn (cons (byte-optimize-form (nth 1 form) for-effect) - (cdr (cdr form))))) + (byte-optimize-body (cddr form) t)))) ((eq fn 'catch) - ;; the body of a catch is compiled (and thus optimized) as a - ;; top-level form, so don't do it here. The tag is never - ;; for-effect. The body should have the same for-effect status - ;; as the catch form itself, but that isn't handled properly yet. + ;; The body of a catch is compiled (and thus optimized) as a + ;; top-level form, but do it here too for the sake of + ;; lexically-oriented code. The tag is never for-effect. (cons fn (cons (byte-optimize-form (nth 1 form) nil) - (cdr (cdr form))))) + (byte-optimize-body (cddr form) for-effect)))) ;; If optimization is on, this is the only place that macros are ;; expanded. If optimization is off, then macroexpansion happens @@ -524,8 +562,11 @@ byte-compile-macro-environment)))) (byte-optimize-form form for-effect)) + ((compiled-function-p fn) + (cons fn (mapcar #'byte-optimize-form (cdr form)))) + ((not (symbolp fn)) - (byte-compile-warn "%s is a malformed function" (prin1-to-string fn)) + (byte-compile-warn "%S is a malformed function" fn) form) ;; Support compiler macros as in cl.el. @@ -537,6 +578,12 @@ (setq tmp (byte-optimize-side-effect-free-p form)) (or byte-compile-delete-errors (eq tmp 'error-free) + ;; XEmacs; GNU handles the expansion of (pop foo) specially + ;; here. We changed the macro to expand to (prog1 (car-safe + ;; PLACE) (setq PLACE (cdr PLACE))) , which has the same + ;; effect. (This only matters when + ;; byte-compile-delete-errors is nil, which is usually true + ;; for GNU and usually false for XEmacs.) (progn (byte-compile-warn "%s called for effect" (prin1-to-string form)) @@ -587,14 +634,17 @@ ;; all-for-effect is true. Returns a new list of forms. (let ((rest forms) (result nil) + (modified nil) fe new) (while rest (setq fe (or all-for-effect (cdr rest))) (setq new (and (car rest) (byte-optimize-form (car rest) fe))) (if (or new (not fe)) - (setq result (cons new result))) + (setq result (cons new result) + modified (or modified (not (eq new (car rest))))) + (setq modified t)) (setq rest (cdr rest))) - (nreverse result))) + (if modified (nreverse result) forms))) ;;; some source-level optimizers @@ -704,7 +754,7 @@ (apply fun (mapcar 'float constants)) (float (apply fun constants))))) (setq form orig) - (setq form (nconc (delq nil form) + (setq form (nconc (delete* nil form) (list (apply fun (nreverse constants))))))))) form)) @@ -781,7 +831,7 @@ (cond ((memq 0 form) (setq form (if (eq (car form) 'logand) (cons 'progn (cdr form)) - (delq 0 (copy-sequence form))))) + (remove* 0 form)))) ((and (eq (car-safe form) 'logior) (memq -1 form)) (cons 'progn (cdr form))) @@ -944,23 +994,20 @@ (nth 1 form)) ((byte-optimize-predicate form)))) -(defun byte-optimize-or (form) +(defun byte-optimize-or (form &optional for-effect) ;; Throw away unneeded nils, and simplify if less than 2 args. ;; XEmacs; change to be more careful about discarding multiple values. - (let* ((memqueued (memq nil form)) - (trailing-nil (and (cdr memqueued) - (equal '(nil) (last form)))) - rest) - ;; A trailing nil indicates to discard multiple values, and we need to - ;; respect that: - (when (and memqueued (cdr memqueued)) - (setq form (delq nil (copy-sequence form))) - (when trailing-nil - (setcdr (last form) '(nil)))) - (setq rest form) - ;; If there is a literal non-nil constant in the args to `or', throw - ;; away all following forms. We can do this because a literal non-nil - ;; constant cannot be multiple. + (if (memq nil form) + (setq form (remove* nil form + ;; A trailing nil indicates to discard multiple + ;; values, and we need to respect that. No need if + ;; this is for-effect, though, multiple values + ;; will be discarded anyway. + :end (if (not for-effect) (1- (length form)))))) + ;; If there is a literal non-nil constant in the args to `or', throw + ;; away all following forms. We can do this because a literal non-nil + ;; constant cannot be multiple. + (let ((rest form)) (while (cdr (setq rest (cdr rest))) (if (byte-compile-trueconstp (car rest)) (setq form (copy-sequence form) @@ -1030,6 +1077,8 @@ (put 'and 'byte-optimizer 'byte-optimize-and) (put 'or 'byte-optimizer 'byte-optimize-or) +(put 'or 'byte-for-effect-optimizer + #'(lambda (form) (byte-optimize-or form t))) (put 'cond 'byte-optimizer 'byte-optimize-cond) (put 'if 'byte-optimizer 'byte-optimize-if) (put 'while 'byte-optimizer 'byte-optimize-while) @@ -1145,7 +1194,27 @@ ;; No bindings (cons 'progn (cdr (cdr form)))) ((or (nth 2 form) (nthcdr 3 form)) - form) + (if (and (eq 'let (car form)) (> (length (nth 1 form)) 2)) + ;; Group constant initialisations together, so we can + ;; just dup in the lap code. Can't group other + ;; initialisations together if they have side-effects, + ;; that would re-order them. + (let ((sort (stable-sort + (copy-list (nth 1 form)) + #'< :key #'(lambda (object) + (cond ((atom object) + most-positive-fixnum) + ((null (cadr object)) + most-positive-fixnum) + ((byte-compile-trueconstp + (cadr object)) + (mod (sxhash (cadr object)) + most-positive-fixnum)) + (t 0)))))) + (if (equal sort (nth 1 form)) + form + `(let ,sort ,@(cddr form)))) + form)) ;; The body is nil ((eq (car form) 'let) (append '(progn) (mapcar 'car-safe (mapcar 'cdr-safe (nth 1 form))) @@ -1459,7 +1528,7 @@ ;; this addr is jumped to (setcdr rest (cons (cons nil (cdr tmp)) (cdr rest))) - (setq tags (delq tmp tags)) + (setq tags (delete* tmp tags)) (setq rest (cdr rest)))) (setq rest (cdr rest)))) (if tags (error "optimizer error: missed tags %s" tags)) @@ -1588,11 +1657,11 @@ (cond ((= tmp 1) (byte-compile-log-lap " %s discard\t-->\t<deleted>" lap0) - (setq lap (delq lap0 (delq lap1 lap)))) + (setq lap (delete* lap0 (delete* lap1 lap)))) ((= tmp 0) (byte-compile-log-lap " %s discard\t-->\t<deleted> discard" lap0) - (setq lap (delq lap0 lap))) + (setq lap (delete* lap0 lap))) ((= tmp -1) (byte-compile-log-lap " %s discard\t-->\tdiscard discard" lap0) @@ -1605,7 +1674,7 @@ ((and (memq (car lap0) byte-goto-ops) (eq (cdr lap0) lap1)) (cond ((eq (car lap0) 'byte-goto) - (setq lap (delq lap0 lap)) + (setq lap (delete* lap0 lap)) (setq tmp "<deleted>")) ((memq (car lap0) byte-goto-always-pop-ops) (setcar lap0 (setq tmp 'byte-discard)) @@ -1662,7 +1731,7 @@ (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) (setq keep-going t rest (cdr rest)) - (setq lap (delq lap0 (delq lap2 lap)))) + (setq lap (delete* lap0 (delete* lap2 lap)))) ;; ;; not goto-X-if-nil --> goto-X-if-non-nil ;; not goto-X-if-non-nil --> goto-X-if-nil @@ -1682,7 +1751,7 @@ (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) 'byte-goto-if-not-nil 'byte-goto-if-nil)) - (setq lap (delq lap0 lap)) + (setq lap (delete* lap0 lap)) (setq keep-going t)) ;; ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: @@ -1699,7 +1768,7 @@ (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" lap0 lap1 lap2 (cons inverse (cdr lap1)) lap2) - (setq lap (delq lap0 lap)) + (setq lap (delete* lap0 lap)) (setcar lap1 inverse) (setq keep-going t))) ;; @@ -1714,13 +1783,13 @@ (byte-compile-log-lap " %s %s\t-->\t<deleted>" lap0 lap1) (setq rest (cdr rest) - lap (delq lap0 (delq lap1 lap)))) + lap (delete* lap0 (delete* lap1 lap)))) (t (if (memq (car lap1) byte-goto-always-pop-ops) (progn (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (cons 'byte-goto (cdr lap1))) - (setq lap (delq lap0 lap))) + (setq lap (delete* lap0 lap))) (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (cons 'byte-goto (cdr lap1)))) (setcar lap1 'byte-goto))) @@ -1765,7 +1834,7 @@ (while (setq tmp2 (rassq lap0 tmp3)) (setcdr tmp2 lap1) (setq tmp3 (cdr (memq tmp2 tmp3)))) - (setq lap (delq lap0 lap) + (setq lap (delete* lap0 lap) keep-going t)) ;; ;; unused-TAG: --> <deleted> @@ -1774,7 +1843,7 @@ (not (rassq lap0 lap))) (and (memq byte-optimize-log '(t byte)) (byte-compile-log " unused tag %d removed" (nth 1 lap0))) - (setq lap (delq lap0 lap) + (setq lap (delete* lap0 lap) keep-going t)) ;; ;; goto ... --> goto <delete until TAG or end> @@ -1829,10 +1898,10 @@ byte-save-restriction)) (< 0 (cdr lap1))) (if (zerop (setcdr lap1 (1- (cdr lap1)))) - (delq lap1 rest)) + (delete* lap1 rest)) (if (eq (car lap0) 'byte-varbind) (setcar rest (cons 'byte-discard 0)) - (setq lap (delq lap0 lap))) + (setq lap (delete* lap0 lap))) (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 (cons (car lap1) (1+ (cdr lap1))) (if (eq (car lap0) 'byte-varbind) @@ -1919,7 +1988,7 @@ (setcdr tmp (cons (byte-compile-make-tag) (cdr tmp)))) (setcdr lap1 (car (cdr tmp))) - (setq lap (delq lap0 lap)))) + (setq lap (delete* lap0 lap)))) (setq keep-going t)) ;; ;; X: varref-Y ... varset-Y goto-X --> @@ -2055,7 +2124,7 @@ (cons 'byte-unbind (+ (cdr lap0) (cdr lap1)))) (setq keep-going t) - (setq lap (delq lap0 lap)) + (setq lap (delete* lap0 lap)) (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) ) (setq rest (cdr rest)))
--- a/lisp/bytecomp.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/bytecomp.el Fri Aug 03 02:05:08 2012 +0900 @@ -522,150 +522,222 @@ #'(lambda (form &optional read-only) (list wrapper form)))) (labels - . ,#'(lambda (bindings &rest body) - (let* ((names (mapcar 'car bindings)) - (lambdas (mapcar - (function* - (lambda ((name . definition)) - (cons 'lambda (cdr (cl-transform-lambda - definition name))))) - bindings)) - (placeholders - (mapcar #'(lambda (lambda) - (make-byte-code (second lambda) "\xc0\x87" - ;; This list is used for - ;; the byte-optimize - ;; property, if the - ;; function is to be - ;; inlined. See - ;; cl-do-proclaim. - (vector nil) 1)) - lambdas)) - (byte-compile-macro-environment - (pairlis names (mapcar - #'(lambda (placeholder) - `(lambda (&rest cl-labels-args) - ;; Be careful not to quote - ;; PLACEHOLDER, otherwise - ;; byte-optimize-funcall inlines - ;; it. - (list* 'funcall ,placeholder - cl-labels-args))) - placeholders) - byte-compile-macro-environment)) - (gensym (gensym))) - (labels - ((byte-compile-transform-labels (form names lambdas - placeholders) - (let* ((inline - (mapcan - #'(lambda (name placeholder lambda) - (and - (eq - (getf (aref - (compiled-function-constants - placeholder) 0) - 'byte-optimizer) - 'byte-compile-inline-expand) - `(((function ,placeholder) - ,(byte-compile-lambda lambda name) - (function ,lambda))))) - names placeholders lambdas)) - (compiled - (mapcar* #'byte-compile-lambda - (if (not inline) - lambdas - ;; See further down for the - ;; rationale of the sublis calls. - (sublis (pairlis - (mapcar #'cadar inline) - (mapcar #'third inline)) - (sublis - (pairlis - (mapcar #'car inline) - (mapcar #'second inline)) - lambdas :test #'equal) - :test #'eq)) - names)) - elt) - (mapc #'(lambda (placeholder function) - (nsubst function placeholder compiled - :test #'eq - :descend-structures t)) - placeholders compiled) - (when inline - (dolist (triad inline) - (nsubst (setq elt (elt compiled - (position (cadar triad) - placeholders))) - (second triad) compiled :test #'eq - :descend-structures t) - (setf (second triad) elt)) - ;; For inlined labels: first, replace uses of - ;; the placeholder in places where it's not an - ;; evident, explicit funcall (that is, where - ;; it is not to be inlined) with the compiled - ;; function: - (setq form (sublis - (pairlis (mapcar #'car inline) - (mapcar #'second inline)) - form :test #'equal) - ;; Now replace uses of the placeholder - ;; where it is an evident funcall with the - ;; lambda, quoted as a function, to allow - ;; byte-optimize-funcall to do its - ;; thing. Note that the lambdas still have - ;; the placeholders, so there's no risk - ;; of recursive inlining. - form (sublis (pairlis - (mapcar #'cadar inline) - (mapcar #'third inline)) - form :test #'eq))) - (sublis (pairlis placeholders compiled) form - :test #'eq)))) - (put gensym 'byte-compile - #'(lambda (form) - (let* ((names (cadr (cl-pop2 form))) - (lambdas (mapcar #'cadr (cdr (pop form)))) - (placeholders (cadr (pop form)))) - (byte-compile-body-do-effect - (byte-compile-transform-labels form names - lambdas - placeholders))))) - (put gensym 'byte-hunk-handler - #'(lambda (form) - (let* ((names (cadr (cl-pop2 form))) - (lambdas (mapcar #'cadr (cdr (pop form)))) - (placeholders (cadr (pop form)))) - (byte-compile-file-form - (cons 'progn - (byte-compile-transform-labels - form names lambdas placeholders)))))) - (setq body - (cl-macroexpand-all `(,gensym ',names (list ,@lambdas) - ',placeholders ,@body) - byte-compile-macro-environment)) - (if (position 'lambda (mapcar #'(lambda (object) - (car-safe (cdr-safe - object))) - (cdr (third body))) - :key #'car-safe :test-not #'eq) - ;; #'lexical-let has worked its magic, not all the - ;; lambdas are lambdas. Give up on pre-compiling the - ;; labels. - (setq names (mapcar #'copy-symbol names) - lambdas (cdr (third body)) - body (sublis (pairlis placeholders names) - (nthcdr 4 body) :test #'eq) - lambdas (sublis (pairlis placeholders names) - lambdas :test #'eq) - body (cl-macroexpand-all - `(lexical-let - ,names - (setf ,@(mapcan #'list names lambdas)) - ,@body) - byte-compile-macro-environment)) - body))))) + . ,(symbol-macrolet ((wrapper '#:labels)) + (labels + ((cannot-inline-alist (placeholders lambdas) + (let ((inline + ;; What labels should be inline? + (remove-if-not + #'(lambda (placeholder) + (eq 'byte-compile-inline-expand + (get placeholder + 'byte-optimizer))) + placeholders))) + ;; Which of those labels--that should be + ;; inline--reference themeselves, or other labels that + ;; should be inline? Give a an alist mapping them to + ;; their data placeholders. + (mapcan + #'(lambda (placeholder lambda) + (and + (eq 'byte-compile-inline-expand + (get placeholder 'byte-optimizer)) + (block find + (subst-if nil + #'(lambda (tree) + (if (memq tree inline) + (return-from find t))) + lambda) + nil) + `((,placeholder + . ,(get placeholder + 'byte-compile-data-placeholder))))) + placeholders lambdas))) + (destructure-labels (form for-effect) + (let* ((names (cadr (cl-pop2 form))) + (lambdas (mapcar #'cadr (cdr (pop form)))) + (placeholders (cadr (pop form))) + (cannot-inline-alist (cannot-inline-alist + placeholders lambdas)) + (lambdas (sublis cannot-inline-alist + lambdas :test #'eq))) + ;; Used specially, note the bindings in our callers. + (setq byte-compile-function-environment + (pairlis + (mapcar #'cdr cannot-inline-alist) + (mapcar #'car cannot-inline-alist) + (pairlis placeholders lambdas + byte-compile-function-environment))) + (if (memq byte-optimize '(t source)) + (setq lambdas + (mapcar #'cadr (mapcar #'byte-optimize-form + lambdas)) + form (byte-optimize-body form for-effect))) + (values placeholders lambdas names form))) + (warn-about-unused-labels (names placeholders) + (when (memq 'unused-vars byte-compile-warnings) + (loop + for placeholder in placeholders + for name in names + if (eql 0 (+ (get placeholder + 'byte-compile-label-calls 0) + (get (get placeholder + 'byte-compile-data-placeholder + '#:no-such-data-placeholder) + 'byte-compile-label-calls 0))) + do (byte-compile-warn + "label %s bound but not referenced" name)))) + (byte-compile-transform-labels (form names lambdas + placeholders) + (let ((compiled + (mapcar* #'byte-compile-lambda lambdas names))) + (warn-about-unused-labels names placeholders) + (mapc #'(lambda (placeholder function) + (nsubst function placeholder compiled + :test #'eq + :descend-structures t) + (nsubst function + (get placeholder + 'byte-compile-data-placeholder) + compiled :test #'eq + :descend-structures t)) + placeholders compiled) + (sublis (pairlis + placeholders compiled + (pairlis + (mapcar* + #'get placeholders + (load-time-value + (let ((list + (list + 'byte-compile-data-placeholder))) + (nconc list list)))) + compiled)) + form :test #'eq)))) + (put wrapper 'byte-compile + #'(lambda (form) + (let ((byte-compile-function-environment + byte-compile-function-environment)) + (multiple-value-bind + (placeholders lambdas names form) + (destructure-labels form for-effect) + (byte-compile-body-do-effect + (byte-compile-transform-labels form names + lambdas + placeholders)))))) + (put wrapper 'byte-hunk-handler + #'(lambda (form) + (let ((byte-compile-function-environment + byte-compile-function-environment)) + (multiple-value-bind + (placeholders lambdas names form) + (destructure-labels form t) + (byte-compile-file-form + (cons 'progn + (byte-compile-transform-labels + form names lambdas placeholders))))))) + (put wrapper 'cl-compiler-macro + ;; This is only used when optimizing code. + #'(lambda (form &rest ignore) + (let ((byte-compile-function-environment + byte-compile-function-environment) + byte-optimize-form retry) + (multiple-value-bind + (placeholders lambdas) + (destructure-labels form for-effect) + ;; Optimize most of the form, in passing + ;; expanding macros. + (setq byte-optimize-form + (mapcar #'byte-optimize-form + (list* (nth 1 form) `(list ,@lambdas) + (cdddr form)))) + ;; It may be reasonable to inline any labels + ;; used only once. + (dolist (placeholder placeholders) + (and + (not (eq 'byte-compile-inline-expand + (get placeholder 'byte-optimizer))) + (eql 0 (get (get placeholder + 'byte-compile-data-placeholder + '#:no-such-data-placeholder) + 'byte-compile-label-calls 0)) + (eql 1 (get placeholder + 'byte-compile-label-calls 0)) + (progn + (byte-compile-log + "label %s is used only once, inlining it" + placeholder) + (setq retry t) + (cl-do-proclaim `(inline ,placeholder) t)))) + (when retry + (multiple-value-setq + (placeholders lambdas) + (destructure-labels form for-effect)) + (setq byte-optimize-form + (mapcar #'byte-optimize-form + (list* (nth 1 form) + `(list ,@lambdas) + (cdddr form))))) + (if (equal (cdr form) byte-optimize-form) + form + (cons (car form) byte-optimize-form))))))) + #'(lambda (bindings &rest body) + (let* ((names (mapcar 'car bindings)) + (lambdas (mapcar + (function* + (lambda ((name . definition)) + `#'(lambda ,@(cdr (cl-transform-lambda + definition name))))) + bindings)) + (placeholders (mapcar #'copy-symbol names)) + (byte-compile-macro-environment + (pairlis names + (mapcar + #'(lambda (placeholder) + `(lambda (&rest byte-compile-labels-args) + (put + ',placeholder + 'byte-compile-label-calls + (1+ (get ',placeholder + 'byte-compile-label-calls + 0))) + (cons ',placeholder + byte-compile-labels-args))) + placeholders) + byte-compile-macro-environment))) + ;; Tell the macroexpansion code what symbol to use when + ;; expanding #'FUNCTION-NAME: + (mapc #'put placeholders + (load-time-value + (let ((list (list 'byte-compile-data-placeholder))) + (nconc list list))) + (mapcar #'copy-symbol names)) + (setq body + (cl-macroexpand-all + `(,wrapper ',names (list ,@lambdas) ',placeholders + ,@body) + byte-compile-macro-environment)) + (if (position 'lambda (mapcar #'(lambda (object) + (car-safe (cdr-safe + object))) + (cdr (third body))) + :key #'car-safe :test-not #'eq) + ;; #'lexical-let has worked its magic, not all the + ;; lambdas are lambdas. Give up on pre-compiling the + ;; labels. + (setq names (mapcar #'copy-symbol names) + lambdas (cdr (third body)) + body (sublis (pairlis placeholders names) + (nthcdr 4 body) :test #'eq) + lambdas (sublis (pairlis placeholders names) + lambdas :test #'eq) + body (cl-macroexpand-all + `(lexical-let + ,names + (setf ,@(mapcan #'list names lambdas)) + ,@body) + byte-compile-macro-environment)) + body))))) (flet . ,#'(lambda (bindings &rest body) (let* ((names (mapcar 'car bindings)) @@ -1488,7 +1560,7 @@ (byte-compile-arglist-signature-string (cons min max)))) (setq byte-compile-unresolved-functions - (delq calls byte-compile-unresolved-functions))))) + (delete* calls byte-compile-unresolved-functions))))) ))) ;; If we have compiled any calls to functions which are not known to be @@ -1503,7 +1575,7 @@ (while rest (if (assq (car (car rest)) byte-compile-autoload-environment) (setq byte-compile-unresolved-functions - (delq (car rest) byte-compile-unresolved-functions))) + (delete* (car rest) byte-compile-unresolved-functions))) (setq rest (cdr rest))))) ;; Now warn. (if (cdr byte-compile-unresolved-functions) @@ -1642,8 +1714,7 @@ (unwind-protect (call-with-condition-handler - #'(lambda (error-info) - (byte-compile-report-error error-info)) + #'byte-compile-report-error #'(lambda () (progn ,@body))) ;; Always set point in log to start of interesting output. @@ -2411,29 +2482,13 @@ (eval form) (byte-compile-keep-pending form 'byte-compile-normal-call)) -;; XEmacs change: be careful about multiple values with these three forms. -(put 'progn 'byte-hunk-handler - #'(lambda (form) - (mapc 'byte-compile-file-form (cdr form)) - ;; Return nil so the forms are not output twice. - nil)) - -(put 'prog1 'byte-hunk-handler - #'(lambda (form) - (when (first form) - (byte-compile-file-form `(or ,(first form) nil)) - (mapc 'byte-compile-file-form (cdr form)) - nil))) - -(put 'prog2 'byte-hunk-handler - #'(lambda (form) - (when (first form) - (byte-compile-file-form (first form)) - (when (second form) - (setq form (cdr form)) - (byte-compile-file-form `(or ,(first form) nil)) - (mapc 'byte-compile-file-form (cdr form)) - nil)))) +(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn) +(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn) +(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn) +(defun byte-compile-file-form-progn (form) + (mapc 'byte-compile-file-form (cdr form)) + ;; Return nil so the forms are not output twice. + nil) ;; This handler is not necessary, but it makes the output from dont-compile ;; and similar macros cleaner. @@ -2773,8 +2828,7 @@ (let ((new-bindings (mapcar #'(lambda (x) (cons x byte-compile-arglist-bit)) (and (memq 'free-vars byte-compile-warnings) - (delq '&rest (delq '&optional - (copy-sequence arglist))))))) + (remove* '&rest (remove* '&optional arglist)))))) (nconc new-bindings (cons 'new-scope byte-compile-bound-variables)))) (body (cdr (cdr fun))) @@ -2979,7 +3033,7 @@ (cons (nth 1 (car body)) (cdr body)) (cons tmp body)))) (or (eq output-type 'file) - (not (delq nil (mapcar 'consp (cdr (car body)))))))) + (notany #'consp (cdar body))))) (setq rest (cdr rest))) rest)) (let ((byte-compile-vector (byte-compile-constants-vector))) @@ -3027,8 +3081,7 @@ (if (memq 'callargs byte-compile-warnings) (byte-compile-callargs-warn form)) (byte-compile-normal-call form)))) - ((and (or (compiled-function-p (car form)) - (eq (car-safe (car form)) 'lambda)) + ((and (eq (car-safe (car form)) 'lambda) ;; if the form comes out the same way it went in, that's ;; because it was malformed, and we couldn't unfold it. (not (eq form (setq form (byte-compile-unfold-lambda form))))) @@ -3065,9 +3118,8 @@ (map nil (function* (lambda ((function . nargs)) - ;; Document that the car of OBJECT, a symbol, describes a function - ;; taking keyword arguments from the argument index described by - ;; the cdr of OBJECT. + ;; Document that FUNCTION, a symbol, describes a function taking + ;; keyword arguments from the argument index described by NARGS. (put function 'byte-compile-keyword-start nargs))) '((adjoin . 3) (assoc* . 3) (assoc-if . 3) (assoc-if-not . 3) (count . 3) (count-if . 3) (count-if-not . 3) (define-behavior . 3) @@ -3830,7 +3882,7 @@ (if (cdr (cdr form)) (byte-compile-out 'byte-insertN (length (cdr form))) (byte-compile-out 'byte-insert 0))) - ((memq t (mapcar 'consp (cdr (cdr form)))) + ((some #'consp (cddr form)) (byte-compile-normal-call form)) ;; We can split it; there is no function call after inserting 1st arg. (t @@ -4192,34 +4244,8 @@ (byte-compile-constp (second form))) (byte-compile-callargs-warn (cons (cl-const-expr-val (second form)) (nthcdr 2 form)))) - (if (and byte-optimize - (eq 'function (car-safe (cadr form))) - (eq 'lambda (car-safe (cadadr form))) - (or - (not (eq (setq form (cons (cadadr form) (cddr form))) - (setq form (byte-compile-unfold-lambda form)))) - (prog1 nil (setq form `(funcall #',(car form) ,@(cdr form)))))) - ;; The byte-compile part of the #'labels implementation, above, - ;; happens after macroexpansion and after the source optimizer has - ;; done its thing. When labels are to be made inline we can have code - ;; that looks like (funcall #'(lambda ...) ...), when the code that - ;; the optimizer saw looked like (funcall #<compiled-function ...> - ;; ...). - ;; - ;; So, the optimizer doesn't have the opportunity to transform the - ;; former to (let (...) ...), and it's reasonable to do that here (since - ;; the labels implementation doesn't change other code that would need - ;; running through the optimizer; the lambda itself has already been - ;; through the optimizer). - ;; - ;; Equally reasonable, and conceptually a bit clearer, would be to do - ;; the transformation to (funcall #'(lambda ...) ...) in the - ;; byte-optimizer, breaking most of the #'sublis calls out of the - ;; byte-compile method. - (byte-compile-form form) - (mapc 'byte-compile-form (cdr form)) - (byte-compile-out 'byte-call (length (cdr (cdr form)))))) - + (mapc 'byte-compile-form (cdr form)) + (byte-compile-out 'byte-call (length (cdr (cdr form))))) (defun byte-compile-let (form) ;; First compute the binding values in the old scope. @@ -4685,7 +4711,7 @@ (let ((calls (assq new byte-compile-unresolved-functions))) (if calls (setq byte-compile-unresolved-functions - (delq calls byte-compile-unresolved-functions))))) + (delete* calls byte-compile-unresolved-functions))))) ;;; tags @@ -4960,10 +4986,15 @@ (batch-byte-recompile-directory)) ;;;###autoload -(defun batch-byte-recompile-directory () +(defun batch-byte-recompile-directory (&optional arg) "Runs `byte-recompile-directory' on the dirs remaining on the command line. Must be used only with `-batch', and kills Emacs on completion. -For example, invoke `xemacs -batch -f batch-byte-recompile-directory .'." +For example, invoke `xemacs -batch -f batch-byte-recompile-directory .'. + +The optional argument is passed to `byte-recompile-directory' as the +prefix argument; see the documentation there for its meaing. +In particular, passing 0 means to compile files for which no `.elc' files +exist." ;; command-line-args-left is what is left of the command line (startup.el) (defvar command-line-args-left) ;Avoid 'free variable' warning (if (not noninteractive) @@ -4972,7 +5003,7 @@ (setq command-line-args-left '("."))) (let ((byte-recompile-directory-ignore-errors-p t)) (while command-line-args-left - (byte-recompile-directory (car command-line-args-left)) + (byte-recompile-directory (car command-line-args-left) arg) (setq command-line-args-left (cdr command-line-args-left)))) (kill-emacs 0))
--- a/lisp/cl-extra.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/cl-extra.el Fri Aug 03 02:05:08 2012 +0900 @@ -569,19 +569,26 @@ ;; This is a bit of a hack; special-case symbols with bindings as ;; labels. (let ((found (cdr (assq (cadr form) env)))) - (if (and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args)) - (if (consp (nth 2 (nth 2 found))) - ;; It's a cons; this is the implementation of - ;; labels in cl-macs.el. - (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env) - ;; It's an atom, almost certainly a compiled function; - ;; we're using the implementation of labels in - ;; bytecomp.el. Quote it with FUNCTION so that code can - ;; tell uses as data apart from the uses with funcall, - ;; where it's unquoted. #### We should warn if (car form) - ;; above is quote, rather than function. - (list 'function (nth 2 (nth 2 found)))) - form)))) + (cond + ((and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args)) + ;; This is the implementation of labels in cl-macs.el. + (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env)) + ((and (consp found) (eq (nth 1 (nth 1 found)) + 'byte-compile-labels-args)) + ;; We're using the implementation of labels in + ;; bytecomp.el. Quote its data-placeholder with FUNCTION so + ;; that code can tell uses as data apart from the uses with + ;; funcall. + (unless (eq 'function (car form)) + (byte-compile-warn + "deprecated: '%s, use #'%s instead to quote it as a function" + (cadr form) (cadr form))) + (setq found (get (nth 1 (nth 1 (nth 3 found))) + 'byte-compile-data-placeholder)) + (put found 'byte-compile-label-calls + (1+ (get found 'byte-compile-label-calls 0))) + (list 'function found)) + (t form))))) ((memq (car form) '(defun defmacro)) (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) ((and (eq (car form) 'progn) (not (cddr form)))
--- a/lisp/cl-macs.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/cl-macs.el Fri Aug 03 02:05:08 2012 +0900 @@ -46,7 +46,7 @@ ;;; Code: (defmacro cl-pop2 (place) - (list 'prog1 (list 'car (list 'cdr place)) + (list 'prog1 (list 'car-safe (list 'cdr-safe place)) (list 'setq place (list 'cdr (list 'cdr place))))) (put 'cl-pop2 'edebug-form-spec 'edebug-sexps) @@ -229,8 +229,12 @@ macro expansion time, reflects all the arguments supplied to the macro, as if it had been declared with a single &rest argument. - &environment specifies local semantics for various macros for use within - the expansion of BODY. See the ENVIRONMENT argument to `macroexpand'. + &environment allows access to the macro environment at the time of + expansion; it is most relevant when it's necessary to force macro expansion + of the body of a form at the time of macro expansion of its top level. + &environment is followed by variable name, and this variable will be bound + to the value of the macro environment within BODY. See the ENVIRONMENT + argument to `macroexpand'. -- The macro arg list syntax allows for \"destructuring\" -- see also `destructuring-bind', which destructures exactly like `defmacro*', and @@ -299,9 +303,9 @@ ;; Clean the list (let ((p (last arg))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) (if (setq junk (cadr (memq '&cl-defs arg))) - (setq arg (delq '&cl-defs (delq junk arg)))) + (setq arg (delete* '&cl-defs (delete* junk arg)))) (if (memq '&cl-quote arg) - (setq arg (delq '&cl-quote arg))) + (setq arg (delete* '&cl-quote arg))) (mapcar 'cl-upcase-arg arg))) (t arg))) ; Maybe we are in initializer @@ -346,13 +350,13 @@ (setq args (if (listp args) (copy-list args) (list '&rest args))) (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) (if (setq bind-defs (cadr (memq '&cl-defs args))) - (setq args (delq '&cl-defs (delq bind-defs args)) + (setq args (delete* '&cl-defs (delete* bind-defs args)) bind-defs (cadr bind-defs))) (if (setq bind-enquote (memq '&cl-quote args)) - (setq args (delq '&cl-quote args))) + (setq args (delete* '&cl-quote args))) (if (memq '&whole args) (error "&whole not currently implemented")) (let* ((p (memq '&environment args)) (v (cadr p))) - (if p (setq args (nconc (delq (car p) (delq v args)) + (if p (setq args (nconc (delete* (car p) (delete* v args)) `(&aux (,v byte-compile-macro-environment)))))) (while (and args (symbolp (car args)) (not (memq (car args) '(nil &rest &body &key &aux))) @@ -715,6 +719,8 @@ ;; as such it can eliminate it if that's appropriate: (put (cdar cl-active-block-names) 'cl-block-name name) `(catch ',(cdar cl-active-block-names) + ;; Can't use &environment, since #'block is used in + ;; #'cl-transform-lambda. ,(cl-macroexpand-all body byte-compile-macro-environment)))) ;;;###autoload @@ -1693,7 +1699,7 @@ '(cl-progv-after)))) ;;;###autoload -(defmacro* macrolet ((&rest macros) &body form) +(defmacro* macrolet ((&rest macros) &body form &environment env) "Make temporary macro definitions. This is like `flet', but for macros instead of functions." (cl-macroexpand-all (cons 'progn form) @@ -1704,10 +1710,10 @@ collect (list* name 'lambda (cdr (cl-transform-lambda details name)))) - byte-compile-macro-environment))) + env))) ;;;###autoload -(defmacro* symbol-macrolet ((&rest symbol-macros) &body form) +(defmacro* symbol-macrolet ((&rest symbol-macros) &body form &environment env) "Make temporary symbol macro definitions. Elements in SYMBOL-MACROS look like (NAME EXPANSION). Within the body FORMs, a reference to NAME is replaced with its EXPANSION, @@ -1717,11 +1723,11 @@ for (name expansion) in symbol-macros do (check-type name symbol) collect (list (eq-hash name) expansion)) - byte-compile-macro-environment))) + env))) (defvar cl-closure-vars nil) ;;;###autoload -(defmacro lexical-let (bindings &rest body) +(defmacro* lexical-let (bindings &rest body &environment env) "Like `let', but lexically scoped. The main visible difference is that lambdas inside BODY will create lexical closures as in Common Lisp." @@ -1743,7 +1749,7 @@ t)) vars) (list '(defun . cl-defun-expander)) - byte-compile-macro-environment)))) + env)))) (if (not (get (car (last cl-closure-vars)) 'used)) (list 'let (mapcar #'(lambda (x) (list (caddr x) (cadr x))) vars) (sublis (mapcar #'(lambda (x) @@ -1863,39 +1869,40 @@ byte-compile-bound-variables)))) ((eq (car-safe spec) 'inline) - (while (setq spec (cdr spec)) - (let ((assq (cdr (assq (car spec) byte-compile-macro-environment)))) - (if (and (consp assq) (eq (nth 1 (nth 1 assq)) 'cl-labels-args) - (atom (setq assq (nth 2 (nth 2 assq))))) - ;; It's a label, and we're using the labels - ;; implementation in bytecomp.el. Tell the compiler - ;; to inline it, don't mark the symbol to be inlined - ;; globally. - (setf (getf (aref (compiled-function-constants assq) 0) - 'byte-optimizer) - 'byte-compile-inline-expand) - (or (memq (get (car spec) 'byte-optimizer) - '(nil byte-compile-inline-expand)) - (error - "%s already has a byte-optimizer, can't make it inline" - (car spec))) - (put (car spec) 'byte-optimizer 'byte-compile-inline-expand))))) + (while (setq spec (cdr spec)) + (let* ((assq (cdr (assq (car spec) + byte-compile-macro-environment))) + (symbol (if (and (consp assq) + (eq (nth 1 (nth 1 assq)) + 'byte-compile-labels-args)) + ;; It's a label, and we're using the labels + ;; implementation in bytecomp.el. Tell the + ;; compiler to inline it, don't mark the + ;; symbol to be inlined globally. + (nth 1 (nth 1 (nth 3 assq))) + (car spec)))) + (or (memq (get symbol 'byte-optimizer) + '(nil byte-compile-inline-expand)) + (error + "%s already has a byte-optimizer, can't make it inline" + symbol)) + (put symbol 'byte-optimizer 'byte-compile-inline-expand)))) ((eq (car-safe spec) 'notinline) (while (setq spec (cdr spec)) - (let ((assq (cdr (assq (car spec) byte-compile-macro-environment)))) - (if (and (consp assq) (eq (nth 1 (nth 1 assq)) 'cl-labels-args) - (atom (setq assq (nth 2 (nth 2 assq))))) - ;; It's a label, and we're using the labels - ;; implementation in bytecomp.el. Tell the compiler - ;; not to inline it. - (if (eq 'byte-compile-inline-expand - (getf (aref (compiled-function-constants assq) 0) - 'byte-optimizer)) - (remf (aref (compiled-function-constants assq) 0) - 'byte-optimizer)) - (if (eq (get (car spec) 'byte-optimizer) - 'byte-compile-inline-expand) - (put (car spec) 'byte-optimizer nil)))))) + (let* ((assq (cdr (assq (car spec) + byte-compile-macro-environment))) + (symbol (if (and (consp assq) + (eq (nth 1 (nth 1 assq)) + 'byte-compile-labels-args)) + ;; It's a label, and we're using the labels + ;; implementation in bytecomp.el. Tell the + ;; compiler not to inline it, don't mark the + ;; symbol to be notinline globally. + (nth 1 (nth 1 (nth 3 assq))) + (car spec)))) + (if (eq (get symbol 'byte-optimizer) + 'byte-compile-inline-expand) + (put symbol 'byte-optimizer nil))))) ((eq (car-safe spec) 'optimize) (let ((speed (assq (nth 1 (assq 'speed (cdr spec))) '((0 . nil) (1 . t) (2 . t) (3 . t)))) @@ -1916,7 +1923,7 @@ (if (consp (car spec)) (if (eq (cadar spec) 0) (setq byte-compile-warnings - (delq (caar spec) byte-compile-warnings)) + (delete* (caar spec) byte-compile-warnings)) (setq byte-compile-warnings (adjoin (caar spec) byte-compile-warnings))))))) nil) @@ -2456,14 +2463,14 @@ ;;;###autoload (defun cl-do-pop (place) (if (cl-simple-expr-p place) - (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place))) + (list 'prog1 (list 'car-safe place) (list 'setf place (list 'cdr place))) (let* ((method (cl-setf-do-modify place t)) (temp (gensym "--pop--"))) (list 'let* (append (car method) (list (list temp (nth 2 method)))) (list 'prog1 - (list 'car temp) + (list 'car-safe temp) (cl-setf-do-store (nth 1 method) (list 'cdr temp))))))) ;;;###autoload @@ -2806,7 +2813,7 @@ (caar include-descs) include)) old-descs) (pop include-descs))) - (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) + (setq descs (append old-descs (delete* (assq 'cl-tag-slot descs) descs)) type (car inc-type) named (assq 'cl-tag-slot descs)) (if (cadr inc-type) (setq tag name named t)) @@ -2822,7 +2829,7 @@ (error "Illegal :type specifier: %s" type)) (if named (setq tag name))) (setq type 'vector named 'true))) - (or named (setq descs (delq (assq 'cl-tag-slot descs) descs))) + (or named (setq descs (delete* (assq 'cl-tag-slot descs) descs))) (push (list 'defvar tag-symbol) forms) (setq pred-form (and named (let ((pos (- (length descs) @@ -2896,8 +2903,8 @@ (push (cons copier t) side-eff))) (if constructor (push (list constructor - (cons '&key (delq nil (copy-sequence slots)))) - constrs)) + (cons '&key (remove* nil slots))) + constrs)) (while constrs (let* ((name (caar constrs)) (args (cadr (pop constrs))) @@ -2988,7 +2995,7 @@ (cl-make-type-test val (apply (get (car type) 'cl-deftype-handler) (cdr type)))) ((memq (car-safe type) '(integer float real number)) - (delq t (list 'and (cl-make-type-test val (car type)) + (delete* t (list 'and (cl-make-type-test val (car type)) (if (memq (cadr type) '(* nil)) t (if (consp (cadr type)) (list '> val (caadr type)) (list '>= val (cadr type)))) @@ -3086,7 +3093,7 @@ (list 'eval-when '(compile load eval) (cl-transform-function-property func 'cl-compiler-macro - (cons (if (memq '&whole args) (delq '&whole args) + (cons (if (memq '&whole args) (delete* '&whole args) (cons '--cl-whole-arg-- args)) body)) (list 'or (list 'get (list 'quote func) '(quote byte-compile)) (list 'put (list 'quote func) '(quote byte-compile) @@ -3196,7 +3203,7 @@ ((most-positive-fixnum-on-32-bit-machines () (1- (lsh 1 30))) (most-negative-fixnum-on-32-bit-machines () (lognot (most-positive-fixnum-on-32-bit-machines)))) - (defun cl-non-fixnum-number-p (object) + (defun cl-non-immediate-number-p (object) "Return t if OBJECT is a number not guaranteed to be immediate." (and (numberp object) (or (not (fixnump object)) @@ -3211,16 +3218,55 @@ (define-compiler-macro eql (&whole form a b) (cond ((eq (cl-const-expr-p a) t) (let ((val (cl-const-expr-val a))) - (if (cl-non-fixnum-number-p val) + (if (cl-non-immediate-number-p val) (list 'equal a b) (list 'eq a b)))) ((eq (cl-const-expr-p b) t) (let ((val (cl-const-expr-val b))) - (if (cl-non-fixnum-number-p val) + (if (cl-non-immediate-number-p val) (list 'equal a b) (list 'eq a b)))) (t form))) +(defun cl-equal-equivalent-to-eq-p (object) + (or (symbolp object) (characterp object) + (and (fixnump object) (not (cl-non-immediate-number-p object))))) + +(defun cl-car-or-pi (object) + (if (consp object) (car object) pi)) + +(defun cl-cdr-or-pi (object) + (if (consp object) (cdr object) pi)) + +(define-compiler-macro equal (&whole form a b) + (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val a pi)) + (cl-equal-equivalent-to-eq-p (cl-const-expr-val b pi))) + (cons 'eq (cdr form)) + form)) + +(define-compiler-macro member (&whole form elt list) + (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val elt pi)) + (every #'cl-equal-equivalent-to-eq-p + (cl-const-expr-val list '(1.0)))) + (cons 'memq (cdr form)) + form)) + +(define-compiler-macro assoc (&whole form elt list) + (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val elt pi)) + (not (find-if-not #'cl-equal-equivalent-to-eq-p + (cl-const-expr-val list '((1.0 . nil))) + :key #'cl-car-or-pi))) + (cons 'assq (cdr form)) + form)) + +(define-compiler-macro rassoc (&whole form elt list) + (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val elt pi)) + (not (find-if-not #'cl-equal-equivalent-to-eq-p + (cl-const-expr-val list '((nil . 1.0))) + :key #'cl-cdr-or-pi))) + (cons 'rassq (cdr form)) + form)) + (macrolet ((define-star-compiler-macros (&rest macros) "For `member*', `assoc*' and `rassoc*' with constant ITEM or @@ -3249,12 +3295,12 @@ `(,',equal-function ,item ,list)) ((and (eq test 'eql) (not (eq not-constant item-val))) - (if (cl-non-fixnum-number-p item-val) + (if (cl-non-immediate-number-p item-val) `(,',equal-function ,item ,list) `(,',eq-function ,item ,list))) ((and (eq test 'eql) (not (eq not-constant list-val))) - (if (some 'cl-non-fixnum-number-p list-val) + (if (some 'cl-non-immediate-number-p list-val) `(,',equal-function ,item ,list) ;; This compiler macro used to limit ;; calls to ,,eq-function to lists where @@ -3306,7 +3352,7 @@ ((not-constant '#:not-constant)) (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant))) (if (and (cdr form) (not (eq not-constant cl-const-expr-val)) - (not (cl-non-fixnum-number-p cl-const-expr-val))) + (not (cl-non-immediate-number-p cl-const-expr-val))) (cons 'delete* (cdr form)) `(delete* ,@(cdr form) :test #'eq)))) form)) @@ -3329,7 +3375,7 @@ ((not-constant '#:not-constant)) (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant))) (if (and (cdr form) (not (eq not-constant cl-const-expr-val)) - (not (cl-non-fixnum-number-p cl-const-expr-val))) + (not (cl-non-immediate-number-p cl-const-expr-val))) (cons 'remove* (cdr form)) `(remove* ,@(cdr form) :test #'eq)))) form)) @@ -3519,7 +3565,7 @@ (cl-seq begin)) (while cl-seq (setq cl-seq (setcdr cl-seq - (delq (car cl-seq) (cdr cl-seq))))) + (delete* (car cl-seq) (cdr cl-seq))))) begin)) ((or (plists-equal cl-keys '(:test 'equal) t) (plists-equal cl-keys '(:test #'equal) t)) @@ -3887,7 +3933,7 @@ (list 'progn form)) ;;;###autoload -(defmacro labels (bindings &rest body) +(defmacro* labels (bindings &rest body &environment env) "Make temporary function bindings. This is like `flet', except the bindings are lexical instead of dynamic. @@ -3907,8 +3953,7 @@ ;; XEmacs; the byte-compiler has a much better implementation of `labels' ;; in `byte-compile-initial-macro-environment' that is used in compiled ;; code. - (let ((vars nil) (sets nil) - (byte-compile-macro-environment byte-compile-macro-environment)) + (let ((vars nil) (sets nil)) (while bindings (let ((var (gensym))) (push var vars) @@ -3918,9 +3963,8 @@ (push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args) (list 'list* '(quote funcall) (list 'quote var) 'cl-labels-args)) - byte-compile-macro-environment))) - (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body)) - byte-compile-macro-environment))) + env))) + (cl-macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) env))) ;;;###autoload (defmacro flet (functions &rest form)
--- a/lisp/cl.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/cl.el Fri Aug 03 02:05:08 2012 +0900 @@ -152,7 +152,7 @@ careful about evaluating each argument only once and in the right order. PLACE may be a symbol, or any generalized variable allowed by `setf'." (if (symbolp place) - `(car (prog1 ,place (setq ,place (cdr ,place)))) + `(car-safe (prog1 ,place (setq ,place (cdr ,place)))) (cl-do-pop place))) (defmacro push (newelt listname)
--- a/lisp/cus-edit.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/cus-edit.el Fri Aug 03 02:05:08 2012 +0900 @@ -878,10 +878,7 @@ ;; Make a choice only amongst the faces under point: (let ((choice (completing-read "Customize face: (default all faces at point) " - (mapcar (lambda (face) - (list (symbol-name face) face)) - faces) - nil t))) + faces nil t))) (if (eql (length choice) 0) (list faces) (list (intern choice))))))))) @@ -1684,33 +1681,28 @@ (defun custom-load-symbol (symbol) "Load all dependencies for SYMBOL." - (unless custom-load-recursion - (let ((custom-load-recursion t) - (loads (get symbol 'custom-loads)) - load) - (while loads - (setq load (car loads) - loads (cdr loads)) - (custom-load-symbol-1 load))))) - -(defun custom-load-symbol-1 (load) - (cond ((symbolp load) - (condition-case nil - (require load) - (error nil))) - ;; Don't reload a file already loaded. - ((and (boundp 'preloaded-file-list) - (member load preloaded-file-list))) - ((assoc load load-history)) - ((assoc (locate-library load) load-history)) - (t - (condition-case nil - ;; Without this, we would load cus-edit recursively. - ;; We are still loading it when we call this, - ;; and it is not in load-history yet. - (or (equal load "cus-edit") - (load-library load)) - (error nil))))) + (labels + ((custom-load-symbol-1 (load) + (cond ((symbolp load) + (condition-case nil + (require load) + (error nil))) + ;; Don't reload a file already loaded. + ((and (boundp 'preloaded-file-list) + (member load preloaded-file-list))) + ((assoc load load-history)) + ((assoc (locate-library load) load-history)) + (t + (condition-case nil + ;; Without this, we would load cus-edit recursively. + ;; We are still loading it when we call this, + ;; and it is not in load-history yet. + (or (equal load "cus-edit") + (load-library load)) + (error nil)))))) + (unless custom-load-recursion + (let ((custom-load-recursion t)) + (map nil #'custom-load-symbol-1 (get symbol 'custom-loads)))))) (defvar custom-already-loaded-custom-defines nil "List of already-loaded `custom-defines' files.") @@ -2969,7 +2961,7 @@ (defun widget-face-value-delete (widget) ;; Remove the child from the options. (let ((child (car (widget-get widget :children)))) - (setq custom-options (delq child custom-options)) + (setq custom-options (delete* child custom-options)) (widget-children-value-delete widget))) (defvar face-history nil @@ -2977,12 +2969,8 @@ (defun widget-face-action (widget &optional event) "Prompt for a face." - (let ((answer (completing-read "Face: " - (mapcar (lambda (face) - (list (symbol-name face))) - (face-list)) - nil nil nil - 'face-history))) + (let ((answer (completing-read "Face: " (face-list) nil nil nil + 'face-history))) (unless (eql (length answer) 0) (widget-value-set widget (intern answer)) (widget-apply widget :notify widget event)
--- a/lisp/easymenu.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/easymenu.el Fri Aug 03 02:05:08 2012 +0900 @@ -223,7 +223,7 @@ (when (featurep 'menubar) (setq ;; Remove this menu from the list of popups we know about. - easy-menu-all-popups (delq menu easy-menu-all-popups) + easy-menu-all-popups (delete* menu easy-menu-all-popups) ;; If there are multiple popup menus available, make the popup menu ;; normally shown with button-3 a menu of them. If there is just one, ;; make that button show it, and no super-menu.
--- a/lisp/faces.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/faces.el Fri Aug 03 02:05:08 2012 +0900 @@ -54,14 +54,10 @@ Such a collection of attributes is called a \"face\"." :group 'emacs) - (defun read-face-name (prompt) (let (face) (while (eql (length face) 0) ; nil or "" - (setq face (completing-read prompt - (mapcar (lambda (x) (list (symbol-name x))) - (face-list)) - nil t))) + (setq face (completing-read prompt (face-list) nil t))) (intern face))) (defun face-interactive (what &optional bool)
--- a/lisp/files.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/files.el Fri Aug 03 02:05:08 2012 +0900 @@ -2838,7 +2838,7 @@ (let ((localval (copy-list (symbol-value hook))) (globalval (copy-list (default-value hook)))) (if (memq t localval) - (setq localval (append (delq t localval) (delq t globalval)))) + (setq localval (append (delete* t localval) (delete* t globalval)))) localval)) (defun basic-save-buffer () @@ -3175,85 +3175,88 @@ If PRED is a zero-argument function, it indicates for each buffer whether to consider it or not when called with that buffer current." (interactive "P") - (save-excursion - ;; `delete-other-windows' can bomb during autoloads generation, so - ;; guard it well. - (if (or noninteractive - (eq (selected-window) (minibuffer-window)) - (not save-some-buffers-query-display-buffer)) - ;; If playing with windows is unsafe or undesired, just do the - ;; usual drill. - (save-some-buffers-1 arg pred nil) - ;; Else, protect the windows. - (when (save-window-excursion - (save-some-buffers-1 arg pred t)) - ;; Force redisplay. - (sit-for 0))))) - -;; XEmacs - do not use queried flag -(defun save-some-buffers-1 (arg pred switch-buffer) - (let* ((switched nil) - (last-buffer nil) - (files-done - (map-y-or-n-p - (lambda (buffer) - (prog1 - (and (buffer-modified-p buffer) - (not (buffer-base-buffer buffer)) - ;; XEmacs addition: - (not (symbol-value-in-buffer 'save-buffers-skip buffer)) - (or - (buffer-file-name buffer) - (and pred - (progn - (set-buffer buffer) - (and buffer-offer-save (> (buffer-size) 0))))) - (or (not (functionp pred)) - (with-current-buffer buffer (funcall pred))) - (if arg - t - ;; #### We should provide a per-buffer means to - ;; disable the switching. For instance, you might - ;; want to turn it off for buffers the contents of - ;; which is meaningless to humans, such as - ;; `.newsrc.eld'. - (when (and switch-buffer - ;; map-y-or-n-p is displaying help - (not (eq last-buffer buffer))) - (unless (one-window-p) - (delete-other-windows)) - (setq switched t) - ;; #### Consider using `display-buffer' here for 21.1! - ;;(display-buffer buffer nil (selected-frame))) - (switch-to-buffer buffer t)) - (if (buffer-file-name buffer) - (format "Save file %s? " - (buffer-file-name buffer)) - (format "Save buffer %s? " - (buffer-name buffer))))) - (setq last-buffer buffer))) - (lambda (buffer) - (set-buffer buffer) - (condition-case () - (save-buffer) - (error nil))) - (buffer-list) - '("buffer" "buffers" "save") - save-some-buffers-action-alist)) - (abbrevs-done - (and save-abbrevs abbrevs-changed - (progn - (if (or arg - (eq save-abbrevs 'silently) - (y-or-n-p (format "Save abbrevs in %s? " abbrev-file-name))) - (write-abbrev-file nil)) - ;; Don't keep bothering user if he says no. - (setq abbrevs-changed nil) - t)))) - (or (> files-done 0) abbrevs-done - (display-message 'no-log "(No files need saving)")) - switched)) - + (labels + ;; XEmacs - do not use queried flag, make this function a label. + ((save-some-buffers-1 (arg pred switch-buffer) + (let* ((switched nil) + (last-buffer nil) + (files-done + (map-y-or-n-p + (lambda (buffer) + (prog1 + (and (buffer-modified-p buffer) + (not (buffer-base-buffer buffer)) + ;; XEmacs addition: + (not (symbol-value-in-buffer + 'save-buffers-skip buffer)) + (or + (buffer-file-name buffer) + (and pred + (progn + (set-buffer buffer) + (and buffer-offer-save (> (buffer-size) + 0))))) + (or (not (functionp pred)) + (with-current-buffer buffer (funcall pred))) + (if arg + t + ;; #### We should provide a per-buffer means + ;; to disable the switching. For instance, + ;; you might want to turn it off for buffers + ;; the contents of which is meaningless to + ;; humans, such as `.newsrc.eld'. + (when (and switch-buffer + ;; map-y-or-n-p is displaying help + (not (eq last-buffer buffer))) + (unless (one-window-p) + (delete-other-windows)) + (setq switched t) + ;; #### Consider using `display-buffer' + ;; here for 21.1! + ;;(display-buffer buffer nil (selected-frame))) + (switch-to-buffer buffer t)) + (if (buffer-file-name buffer) + (format "Save file %s? " + (buffer-file-name buffer)) + (format "Save buffer %s? " + (buffer-name buffer))))) + (setq last-buffer buffer))) + (lambda (buffer) + (set-buffer buffer) + (condition-case () + (save-buffer) + (error nil))) + (buffer-list) + '("buffer" "buffers" "save") + save-some-buffers-action-alist)) + (abbrevs-done + (and save-abbrevs abbrevs-changed + (progn + (if (or arg + (eq save-abbrevs 'silently) + (y-or-n-p (format "Save abbrevs in %s? " + abbrev-file-name))) + (write-abbrev-file nil)) + ;; Don't keep bothering user if he says no. + (setq abbrevs-changed nil) + t)))) + (or (> files-done 0) abbrevs-done + (display-message 'no-log "(No files need saving)")) + switched))) + (save-excursion + ;; `delete-other-windows' can bomb during autoloads generation, so + ;; guard it well. + (if (or noninteractive + (eq (selected-window) (minibuffer-window)) + (not save-some-buffers-query-display-buffer)) + ;; If playing with windows is unsafe or undesired, just do the + ;; usual drill. + (save-some-buffers-1 arg pred nil) + ;; Else, protect the windows. + (when (save-window-excursion + (save-some-buffers-1 arg pred t)) + ;; Force redisplay. + (sit-for 0)))))) (defun not-modified (&optional arg) @@ -4065,13 +4068,9 @@ (file-directory-p (directory-file-name (car dirs)))) (let ((this-dir-contents ;; Filter out "." and ".." - (delq nil - (mapcar #'(lambda (name) - (unless (string-match "\\`\\.\\.?\\'" - (file-name-nondirectory name)) - name)) - (directory-files (or (car dirs) ".") full - (wildcard-to-regexp nondir)))))) + (nset-difference (directory-files (or (car dirs) ".") full + (wildcard-to-regexp nondir)) + '("." "..") :test #'equal))) (setq contents (nconc (if (and (car dirs) (not full)) @@ -4483,14 +4482,46 @@ (error "Apparently circular symlink path")))) ;; Suggested by Michael Kifer <kifer@CS.SunySB.EDU> -(defun file-remote-p (file-name) - "Test whether FILE-NAME is looked for on a remote system." - (cond ((not (declare-boundp allow-remote-paths)) nil) - ((fboundp 'ange-ftp-ftp-path) - (declare-fboundp (ange-ftp-ftp-path file-name))) - ((fboundp 'efs-ftp-path) - (declare-fboundp (efs-ftp-path file-name))) - (t nil))) +(defun file-remote-p (file &optional identification connected) + "Test whether FILE specifies a location on a remote system. +Return an identification of the system if the location is indeed +remote. The identification of the system may comprise a method +to access the system and its hostname, amongst other things. + +For example, the filename \"/user@host:/foo\" specifies a location +on the system \"/user@host:\". + +IDENTIFICATION specifies which part of the identification shall +be returned as string. IDENTIFICATION can be the symbol +`method', `user' or `host'; any other value is handled like nil +and means to return the complete identification string. + +If CONNECTED is non-nil, the function returns an identification only +if FILE is located on a remote system, and a connection is established +to that remote system. + +`file-remote-p' will never open a connection on its own." + (let ((handler (find-file-name-handler file 'file-remote-p))) + (cond + (handler + (funcall handler 'file-remote-p file identification connected)) + ;; legacy code; can probably go by mid-2008 + ((fboundp 'efs-ftp-path) + (let ((parsed (declare-fboundp (efs-ftp-path file)))) + (and parsed + (let ((host (nth 0 parsed)) + (user (nth 1 parsed))) + (and (or (not connected) + (let ((proc (get-process (declare-fboundp (efs-ftp-process-buffer host user))))) + (and proc (processp proc) + (memq (process-status proc) '(run open))))) + (cond + ((eq identification 'method) (and parsed "ftp")) + ((eq identification 'user) user) + ((eq identification 'host) host) + (t + (concat "/" user "@" host ":/")))))))) + (t nil)))) ;; We use /: as a prefix to "quote" a file name
--- a/lisp/font-lock.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/font-lock.el Fri Aug 03 02:05:08 2012 +0900 @@ -987,14 +987,14 @@ ;; A new set of keywords is defined. Forget all about ;; our old keywords that should be removed. (setq font-lock-removed-keywords-alist - (delq cell font-lock-removed-keywords-alist)) + (delete* cell font-lock-removed-keywords-alist)) ;; Delete all previously removed keywords. (dolist (kword keywords) (setcdr cell (delete kword (cdr cell)))) ;; Delete the mode cell if empty. (if (null (cdr cell)) (setq font-lock-removed-keywords-alist - (delq cell font-lock-removed-keywords-alist))))))) + (delete* cell font-lock-removed-keywords-alist))))))) ;; Written by Anders Lindgren <andersl@andersl.com>. ;; @@ -1053,7 +1053,7 @@ ;; was deleted. (if (null (cdr top-cell)) (setq font-lock-keywords-alist - (delq top-cell font-lock-keywords-alist)))) + (delete* top-cell font-lock-keywords-alist)))) ;; Remember the keyword in case it is not local. (let ((cell (assq mode font-lock-removed-keywords-alist))) (if cell
--- a/lisp/frame.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/frame.el Fri Aug 03 02:05:08 2012 +0900 @@ -218,7 +218,7 @@ ;; frame, then we need to create the opening frame. Make sure ;; it has a minibuffer, but let initial-frame-plist omit the ;; minibuffer spec. - (or (delq terminal-frame (minibuffer-frame-list)) + (or (delete* terminal-frame (minibuffer-frame-list)) (progn (setq frame-initial-frame-plist (append initial-frame-plist default-frame-plist)) @@ -230,8 +230,8 @@ (setq default-minibuffer-frame (setq frame-initial-frame (make-frame initial-frame-plist - (car (delq terminal-device - (device-list)))))) + (car (delete* terminal-device + (device-list)))))) ;; Delete any specifications for window geometry properties ;; so that we won't reapply them in frame-notice-user-settings. ;; It would be wrong to reapply them then, @@ -465,7 +465,7 @@ ;; The initial frame, which we are about to delete, may be ;; the only frame with a minibuffer. If it is, create a ;; new one. - (or (delq frame-initial-frame (minibuffer-frame-list)) + (or (delete* frame-initial-frame (minibuffer-frame-list)) (make-initial-minibuffer-frame nil)) ;; If the initial frame is serving as a surrogate @@ -991,7 +991,7 @@ (face-list-to-change (face-list))) (when (eq (device-type) 'mswindows) (setq face-list-to-change - (delq 'border-glyph face-list-to-change))) + (delete* 'border-glyph face-list-to-change))) ;; FIXME: Is it sufficient to just change the default face, due to ;; face inheritance? (dolist (face face-list-to-change) @@ -1325,7 +1325,7 @@ (unless frame (setq frame (selected-frame))) (let* ((mini-frame (window-frame (minibuffer-window frame))) - (frames (delq mini-frame (delq frame (frame-list))))) + (frames (delete* mini-frame (delete* frame (frame-list))))) (mapc 'delete-frame frames))) ;; XEmacs change: we still use delete-frame-hook @@ -1699,7 +1699,7 @@ ;; but the selected frame should come first, even if it's occluded, ;; to minimize thrashing. (setq frames (cons (selected-frame) - (delq (selected-frame) frames))) + (delete* (selected-frame) frames))) (setq name (symbol-name name)) (while frames @@ -1760,7 +1760,7 @@ (t)))))) ;; put the selected frame last. The user wants a new frame, ;; so don't reuse the existing one unless forced to. - (setq frames (append (delq (selected-frame) frames) (list frames))) + (setq frames (append (delete* (selected-frame) frames) (list frames))) (if (or (eq limit 0) ; means create with reckless abandon (< (length frames) limit)) (get-frame-for-buffer-make-new-frame buffer)
--- a/lisp/gnuserv.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/gnuserv.el Fri Aug 03 02:05:08 2012 +0900 @@ -551,7 +551,7 @@ editing has ended." (let* ((buf (current-buffer))) (dolist (client (gnuserv-buffer-clients buf)) - (callf2 delq buf (gnuclient-buffers client)) + (callf2 delete* buf (gnuclient-buffers client)) ;; If no more buffers, kill the client. (when (null (gnuclient-buffers client)) (gnuserv-kill-client client))))) @@ -588,7 +588,7 @@ ;; killing the device, because it would cause a device-dead ;; error when `delete-device' tries to do the job later. (gnuserv-kill-client client t)))) - (callf2 delq device gnuserv-devices)) + (callf2 delete* device gnuserv-devices)) (add-hook 'delete-device-hook 'gnuserv-check-device) @@ -608,7 +608,7 @@ the function will not remove the frames associated with the client." ;; Order is important: first delete client from gnuserv-clients, to ;; prevent gnuserv-buffer-done-1 calling us recursively. - (callf2 delq client gnuserv-clients) + (callf2 delete* client gnuserv-clients) ;; Process the buffers. (mapc 'gnuserv-buffer-done-1 (gnuclient-buffers client)) (unless leave-frame @@ -636,7 +636,7 @@ ;; Do away with the buffer. (defun gnuserv-buffer-done-1 (buffer) (dolist (client (gnuserv-buffer-clients buffer)) - (callf2 delq buffer (gnuclient-buffers client)) + (callf2 delete* buffer (gnuclient-buffers client)) (when (null (gnuclient-buffers client)) (gnuserv-kill-client client))) ;; Get rid of the buffer.
--- a/lisp/gtk-font-menu.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/gtk-font-menu.el Fri Aug 03 02:05:08 2012 +0900 @@ -146,7 +146,7 @@ done) (setq sizes (cons (car common) sizes))) (setq common (cdr common))) - (setq sizes (delq 0 sizes)))) + (setq sizes (delete* 0 sizes)))) (setq families (sort families 'string-lessp) weights (sort weights 'string-lessp)
--- a/lisp/gui.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/gui.el Fri Aug 03 02:05:08 2012 +0900 @@ -91,24 +91,24 @@ (set-face-foreground 'gui-button-face '(((win color) . "black"))))) -(defun gui-button-action (instance action user-data) - (let ((domain (image-instance-domain instance))) - (with-current-buffer (if (windowp domain) - (window-buffer domain) nil) - (funcall action user-data)))) - (defun make-gui-button (string &optional action user-data) "Make a GUI button whose label is STRING and whose action is ACTION. If the button is inserted in a buffer and then clicked on, and ACTION is non-nil, ACTION will be called with one argument, USER-DATA. When ACTION is called, the buffer containing the button is made current." - (vector 'button - :descriptor string - :face 'gui-button-face - :callback-ex `(lambda (image-instance event) - (gui-button-action image-instance - (quote ,action) - (quote ,user-data))))) + (labels + ((gui-button-action (instance action user-data) + (let ((domain (image-instance-domain instance))) + (with-current-buffer (if (windowp domain) + (window-buffer domain) nil) + (funcall action user-data))))) + (vector 'button + :descriptor string + :face 'gui-button-face + :callback-ex + `(lambda (image-instance event) + (funcall ,#'gui-button-action image-instance ',action + ',user-data))))) (defun insert-gui-button (button &optional pos buffer) "Insert GUI button BUTTON at POS in BUFFER."
--- a/lisp/gutter-items.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/gutter-items.el Fri Aug 03 02:05:08 2012 +0900 @@ -270,10 +270,10 @@ (not in-deletion) (not (eq first-buf (window-buffer (selected-window frame))))) (setq buffers (cons (window-buffer (selected-window frame)) - (delq first-buf buffers)))) + (delete* first-buf buffers)))) ;; if we're in deletion ignore the current buffer (when in-deletion - (setq buffers (delq (current-buffer) buffers)) + (setq buffers (delete* (current-buffer) buffers)) (setq first-buf (car buffers))) ;; filter buffers (when buffers-tab-filter-functions
--- a/lisp/gutter.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/gutter.el Fri Aug 03 02:05:08 2012 +0900 @@ -91,7 +91,7 @@ (if visible-p (if (memq prop spec) spec (cons prop spec)) - (delq prop spec)) + (delete* prop spec)) (if visible-p (list prop)))) (list prop visible-p) 'force nil locale tag-set)
--- a/lisp/indent.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/indent.el Fri Aug 03 02:05:08 2012 +0900 @@ -48,20 +48,20 @@ (defun indent-for-tab-command (&optional prefix-arg) "Indent line in proper way for current major mode." (interactive "P") - (if (eq indent-line-function 'indent-to-left-margin) - (insert-tab prefix-arg) - (if prefix-arg - (funcall indent-line-function prefix-arg) - (funcall indent-line-function)))) - -(defun insert-tab (&optional prefix-arg) - (let ((count (prefix-numeric-value prefix-arg))) - (if abbrev-mode - (expand-abbrev)) - (if indent-tabs-mode - (insert-char ?\t count) - ;; XEmacs: (Need the `1+') - (indent-to (* tab-width (1+ (/ (current-column) tab-width))))))) + (labels + ((insert-tab (&optional prefix-arg) + (let ((count (prefix-numeric-value prefix-arg))) + (if abbrev-mode + (expand-abbrev)) + (if indent-tabs-mode + (insert-char ?\t count) + ;; XEmacs: (Need the `1+') + (indent-to (* tab-width (1+ (/ (current-column) tab-width)))))))) + (if (eq indent-line-function 'indent-to-left-margin) + (insert-tab prefix-arg) + (if prefix-arg + (funcall indent-line-function prefix-arg) + (funcall indent-line-function))))) (defun indent-rigidly (start end count) "Indent all lines starting in the region sideways by COUNT columns.
--- a/lisp/info.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/info.el Fri Aug 03 02:05:08 2012 +0900 @@ -798,7 +798,7 @@ (if (re-search-backward regexp beg t) (throw 'foo t)))) (setq found nil) - (let ((bufs (delq nil (mapcar 'get-file-buffer + (let ((bufs (delete* nil (mapcar 'get-file-buffer Info-annotations-path))) (pattern (if (string-match "\\`<<.*>>\\'" qnode) qnode (format "\"%s\"\\|<<%s>>" qnode qnode))) @@ -1384,7 +1384,7 @@ (let* ((name (format "(%s)%s" (Info-file-name-only file) node)) (found (assoc name Info-history))) (if found - (setq Info-history (delq found Info-history))) + (setq Info-history (delete* found Info-history))) (setq Info-history (cons (list name (- point (point-min)) (and (eq (window-buffer) (current-buffer)) @@ -1702,7 +1702,7 @@ (defun Info-build-annotation-completions () (or Info-current-annotation-completions (save-excursion - (let ((bufs (delq nil (mapcar 'get-file-buffer + (let ((bufs (delete* nil (mapcar 'get-file-buffer Info-annotations-path))) (compl nil)) (while bufs @@ -2360,7 +2360,7 @@ ;; Here it is a feature that assoc is case-sensitive. (while (setq found (assoc topic matches)) (setq exact (cons found exact) - matches (delq found matches))) + matches (delete* found matches))) (setq Info-index-alternatives (nconc exact matches) Info-index-first-alternative (car Info-index-alternatives)) (Info-index-next 0))) @@ -2528,7 +2528,7 @@ (defun Info-reannotate-node () - (let ((bufs (delq nil (mapcar 'get-file-buffer Info-annotations-path)))) + (let ((bufs (delete* nil (mapcar 'get-file-buffer Info-annotations-path)))) (if bufs (let ((ibuf (current-buffer)) (file (concat "\\(" (regexp-quote
--- a/lisp/isearch-mode.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/isearch-mode.el Fri Aug 03 02:05:08 2012 +0900 @@ -1220,38 +1220,37 @@ ;;=========================================================== ;; Search Ring -(defun isearch-ring-adjust1 (advance) - ;; Helper for isearch-ring-adjust - (let* ((ring (if isearch-regexp regexp-search-ring search-ring)) - (length (length ring)) - (yank-pointer-name (if isearch-regexp - 'regexp-search-ring-yank-pointer - 'search-ring-yank-pointer)) - (yank-pointer (eval yank-pointer-name))) - (if (zerop length) - () - (set yank-pointer-name - (setq yank-pointer - (mod (+ (or yank-pointer 0) - ;; XEmacs change - (if advance -1 (if yank-pointer 1 0))) - length))) - (setq isearch-string (nth yank-pointer ring) - isearch-message (mapconcat 'isearch-text-char-description - isearch-string ""))))) - (defun isearch-ring-adjust (advance) ;; Helper for isearch-ring-advance and isearch-ring-retreat ; (if (cdr isearch-cmds) ;; is there more than one thing on stack? ; (isearch-pop-state)) - (isearch-ring-adjust1 advance) - (if search-ring-update - (progn - (isearch-search) - (isearch-update)) - (isearch-edit-string) - ) - (isearch-push-state)) + (labels + ((isearch-ring-adjust1 (advance) + ;; Helper for isearch-ring-adjust + (let* ((ring (if isearch-regexp regexp-search-ring search-ring)) + (length (length ring)) + (yank-pointer-name (if isearch-regexp + 'regexp-search-ring-yank-pointer + 'search-ring-yank-pointer)) + (yank-pointer (symbol-value yank-pointer-name))) + (if (zerop length) + () + (set yank-pointer-name + (setq yank-pointer + (mod (+ (or yank-pointer 0) + ;; XEmacs change + (if advance -1 (if yank-pointer 1 0))) + length))) + (setq isearch-string (nth yank-pointer ring) + isearch-message (mapconcat 'isearch-text-char-description + isearch-string "")))))) + (isearch-ring-adjust1 advance) + (if search-ring-update + (progn + (isearch-search) + (isearch-update)) + (isearch-edit-string)) + (isearch-push-state))) (defun isearch-ring-advance () "Advance to the next search string in the ring." @@ -1582,60 +1581,70 @@ ;; cases. (setq this-command (key-binding (this-command-keys)))) (t - (isearch-maybe-frob-keyboard-macros) - (if (and this-command - (symbolp this-command) - (get this-command 'isearch-command)) - nil ; then continue. - (isearch-done))))) - -(defun isearch-maybe-frob-keyboard-macros () - ;; - ;; If the command about to be executed is `self-insert-command' then change - ;; the command to `isearch-printing-char' instead, meaning add the last- - ;; typed character to the search string. - ;; - ;; If `this-command' is a string or a vector (that is, a keyboard macro) - ;; and it contains only one command, which is bound to self-insert-command, - ;; then do the same thing as for self-inserting commands: arrange for that - ;; character to be added to the search string. If we didn't do this, then - ;; typing a compose sequence (a la x-compose.el) would terminate the search - ;; and insert the character, instead of searching for that character. - ;; - ;; We should continue doing this, since it's pretty much the behavior one - ;; would expect, but it will stop being so necessary once key-translation- - ;; map exists and is used by x-compose.el and things like it, since the - ;; translation will have been done before we see the keys. - ;; - (cond ((eq this-command 'self-insert-command) - (setq this-command 'isearch-printing-char)) - ((and (or (stringp this-command) (vectorp this-command)) - (eq (key-binding this-command) 'self-insert-command)) - (setq last-command-event (character-to-event (aref this-command 0)) - last-command-char (and (stringp this-command) - (aref this-command 0)) - this-command 'isearch-printing-char)) - ((and (null this-command) - (eq 'key-press (event-type last-command-event)) - (current-local-map) - (let* ((this-command-keys (this-command-keys)) - (this-command-keys (or (lookup-key function-key-map - this-command-keys) - this-command-keys)) - (lookup-key (lookup-key global-map this-command-keys))) - (and (eq 'self-insert-command lookup-key) - ;; The feature here that a modification of - ;; last-command-event is respected is undocumented, and - ;; only applies when this-command is nil. The design - ;; isn't reat, and I welcome suggestions for a better - ;; one. - (setq last-command-event - (find-if 'key-press-event-p this-command-keys - :from-end t) - last-command-char - (event-to-character last-command-event) - this-command 'isearch-printing-char))))))) - + (labels + ((isearch-maybe-frob-keyboard-macros () + ;; If the command about to be executed is + ;; `self-insert-command' then change the command to + ;; `isearch-printing-char' instead, meaning add the last- + ;; typed character to the search string. + ;; + ;; If `this-command' is a string or a vector (that is, a + ;; keyboard macro) and it contains only one command, which is + ;; bound to self-insert-command, then do the same thing as for + ;; self-inserting commands: arrange for that character to be + ;; added to the search string. If we didn't do this, then + ;; typing a compose sequence (a la x-compose.el) would + ;; terminate the search and insert the character, instead of + ;; searching for that character. + ;; + ;; We should continue doing this, since it's pretty much the + ;; behavior one would expect, but it will stop being so + ;; necessary once key-translation- map exists and is used by + ;; x-compose.el and things like it, since the translation will + ;; have been done before we see the keys. + ;; + (cond ((eq this-command 'self-insert-command) + (setq this-command 'isearch-printing-char)) + ((and (or (stringp this-command) (vectorp this-command)) + (eq (key-binding this-command) + 'self-insert-command)) + (setq last-command-event + (character-to-event (aref this-command 0)) + last-command-char (and (stringp this-command) + (aref this-command 0)) + this-command 'isearch-printing-char)) + ((and (null this-command) + (eq 'key-press (event-type last-command-event)) + (current-local-map) + (let* ((this-command-keys (this-command-keys)) + (this-command-keys (or (lookup-key + function-key-map + this-command-keys) + this-command-keys)) + (lookup-key (lookup-key global-map + this-command-keys))) + (and (eq 'self-insert-command lookup-key) + ;; The feature here that a modification + ;; of last-command-event is respected is + ;; undocumented, and only applies when + ;; this-command is nil. The design isn't + ;; great, and I welcome suggestions for a + ;; better one. + (setq last-command-event + (find-if 'key-press-event-p + this-command-keys + :from-end t) + last-command-char + (event-to-character + last-command-event) + this-command + 'isearch-printing-char)))))))) + (isearch-maybe-frob-keyboard-macros) + (if (and this-command + (symbolp this-command) + (get this-command 'isearch-command)) + nil ; then continue. + (isearch-done)))))) ;;;======================================================== ;;; Highlighting @@ -1645,24 +1654,25 @@ ;; this face is initialized by faces.el since isearch is preloaded. ;(make-face 'isearch) -(defun isearch-make-extent (begin end) - (let ((x (make-extent begin end (current-buffer)))) - ;; make the isearch extent always take precedence over any mouse- - ;; highlighted extents we may be passing through, since isearch, being - ;; modal, is more interesting (there's nothing they could do with a - ;; mouse-highlighted extent while in the midst of a search anyway). - (set-extent-priority x (+ mouse-highlight-priority 2)) - (set-extent-face x 'isearch) - (setq isearch-extent x))) - (defun isearch-highlight (begin end) - (if (null search-highlight) - nil - ;; make sure isearch-extent is in the current buffer - (or (and (extentp isearch-extent) - (extent-live-p isearch-extent)) - (isearch-make-extent begin end)) - (set-extent-endpoints isearch-extent begin end (current-buffer)))) + (labels + ((isearch-make-extent (begin end) + (let ((x (make-extent begin end (current-buffer)))) + ;; make the isearch extent always take precedence over any mouse- + ;; highlighted extents we may be passing through, since isearch, + ;; being modal, is more interesting (there's nothing they could do + ;; with a mouse-highlighted extent while in the midst of a search + ;; anyway). + (set-extent-priority x (+ mouse-highlight-priority 2)) + (set-extent-face x 'isearch) + (setq isearch-extent x)))) + (if (null search-highlight) + nil + ;; make sure isearch-extent is in the current buffer + (or (and (extentp isearch-extent) + (extent-live-p isearch-extent)) + (isearch-make-extent begin end)) + (set-extent-endpoints isearch-extent begin end (current-buffer))))) ;; This used to have a TOTALLY flag that also deleted the extent. I ;; don't think this is necessary any longer, as isearch-highlight can
--- a/lisp/itimer.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/itimer.el Fri Aug 03 02:05:08 2012 +0900 @@ -102,62 +102,6 @@ (defvar itimer-edit-start-marker nil) -;; macros must come first... or byte-compile'd code will throw back its -;; head and scream. - -(defmacro itimer-decrement (variable) - (list 'setq variable (list '1- variable))) - -(defmacro itimer-increment (variable) - (list 'setq variable (list '1+ variable))) - -(defmacro itimer-signum (n) - (list 'if (list '> n 0) 1 - (list 'if (list 'zerop n) 0 -1))) - -;; Itimer access functions should behave as if they were subrs. These -;; macros are used to check the arguments to the itimer functions and -;; signal errors appropriately if the arguments are not valid. - -(defmacro check-itimer (var) - "If VAR is not bound to an itimer, signal `wrong-type-argument'. -This is a macro." - (list 'setq var - (list 'if (list 'itimerp var) var - (list 'signal ''wrong-type-argument - (list 'list ''itimerp var))))) - -(defmacro check-itimer-coerce-string (var) - "If VAR is bound to a string, look up the itimer that it names and -bind VAR to it. Otherwise, if VAR is not bound to an itimer, signal -`wrong-type-argument'. This is a macro." - (list 'setq var - (list 'cond - (list (list 'itimerp var) var) - (list (list 'stringp var) (list 'get-itimer var)) - (list t (list 'signal ''wrong-type-argument - (list 'list ''string-or-itimer-p var)))))) - -(defmacro check-nonnegative-number (var) - "If VAR is not bound to a number, signal `wrong-type-argument'. -If VAR is not bound to a positive number, signal `args-out-of-range'. -This is a macro." - (list 'setq var - (list 'if (list 'not (list 'numberp var)) - (list 'signal ''wrong-type-argument - (list 'list ''natnump var)) - (list 'if (list '< var 0) - (list 'signal ''args-out-of-range (list 'list var)) - var)))) - -(defmacro check-string (var) - "If VAR is not bound to a string, signal `wrong-type-argument'. -This is a macro." - (list 'setq var - (list 'if (list 'stringp var) var - (list 'signal ''wrong-type-argument - (list 'list ''stringp var))))) - ;; Functions to access and modify itimer attributes. (defun itimerp (object) @@ -173,24 +117,24 @@ (defun itimer-name (itimer) "Return the name of ITIMER." - (check-itimer itimer) + (check-type itimer itimer) (car itimer)) (defun itimer-value (itimer) "Return the number of seconds until ITIMER expires." - (check-itimer itimer) + (check-type itimer itimer) (nth 1 itimer)) (defun itimer-restart (itimer) "Return the value to which ITIMER will be set at restart. The value nil is returned if this itimer isn't set to restart." - (check-itimer itimer) + (check-type itimer itimer) (nth 2 itimer)) (defun itimer-function (itimer) "Return the function of ITIMER. This function is called each time ITIMER expires." - (check-itimer itimer) + (check-type itimer itimer) (nth 3 itimer)) (defun itimer-is-idle (itimer) @@ -198,31 +142,31 @@ Normal timers expire after a set interval. Idle timers expire only after Emacs has been idle for a specific interval. ``Idle'' means no command events have occurred within the interval." - (check-itimer itimer) + (check-type itimer itimer) (nth 4 itimer)) (defun itimer-uses-arguments (itimer) "Return non-nil if the function of ITIMER will be called with arguments. ITIMER's function is called with the arguments each time ITIMER expires. The arguments themselves are retrievable with `itimer-function-arguments'." - (check-itimer itimer) + (check-type itimer itimer) (nth 5 itimer)) (defun itimer-function-arguments (itimer) "Return the function arguments of ITIMER as a list. ITIMER's function is called with these arguments each time ITIMER expires." - (check-itimer itimer) + (check-type itimer itimer) (nth 6 itimer)) (defun itimer-recorded-run-time (itimer) - (check-itimer itimer) + (check-type itimer itimer) (nth 7 itimer)) (defun set-itimer-name (itimer name) "Set the name of ITIMER to be NAME. NAME is an identifier for the itimer. It must be a string. If an active itimer already exists with this name, an error is signaled." - (check-string name) + (check-type name string) (and (itimer-live-p itimer) (get-itimer name) (error "itimer named \"%s\" already existing and activated" name)) @@ -235,8 +179,9 @@ VALUE can be a floating point number. Otherwise it must be an integer. Returns VALUE." - (check-itimer itimer) - (check-nonnegative-number value) + (check-type itimer itimer) + (check-type value number) + (check-argument-range value 0 nil) (let ((inhibit-quit t)) ;; If the itimer is in the active list, and under the new ;; timeout value would expire before we would normally @@ -253,8 +198,9 @@ ;; Same as set-itimer-value but does not wakeup the driver. ;; Only should be used by the drivers when processing expired timers. (defun set-itimer-value-internal (itimer value) - (check-itimer itimer) - (check-nonnegative-number value) + (check-type itimer itimer) + (check-type value number) + (check-argument-range value 0 nil) (setcar (cdr itimer) value)) (defun set-itimer-restart (itimer restart) @@ -264,22 +210,24 @@ RESTART can be a floating point number. Otherwise it must be an integer. Returns RESTART." - (check-itimer itimer) - (if restart (check-nonnegative-number restart)) + (check-type itimer itimer) + (when restart + (check-type restart number) + (check-argument-range restart 0 nil)) (setcar (cdr (cdr itimer)) restart)) (defun set-itimer-function (itimer function) "Set the function of ITIMER to be FUNCTION. FUNCTION will be called when itimer expires. Returns FUNCTION." - (check-itimer itimer) + (check-type itimer itimer) (setcar (nthcdr 3 itimer) function)) (defun set-itimer-is-idle (itimer flag) "Set flag that says whether ITIMER is an idle timer. If FLAG is non-nil, then ITIMER will be considered an idle timer. Returns FLAG." - (check-itimer itimer) + (check-type itimer itimer) (setcar (nthcdr 4 itimer) flag)) (defun set-itimer-uses-arguments (itimer flag) @@ -287,23 +235,23 @@ If FLAG is non-nil, then the function will be called with one argument, otherwise the function will be called with no arguments. Returns FLAG." - (check-itimer itimer) + (check-type itimer itimer) (setcar (nthcdr 5 itimer) flag)) (defun set-itimer-function-arguments (itimer &optional arguments) "Set the function arguments of ITIMER to be ARGUMENTS. The function of ITIMER will be called with ARGUMENTS when itimer expires. Returns ARGUMENTS." - (check-itimer itimer) + (check-type itimer itimer) (setcar (nthcdr 6 itimer) arguments)) (defun set-itimer-recorded-run-time (itimer time) - (check-itimer itimer) + (check-type itimer itimer) (setcar (nthcdr 7 itimer) time)) (defun get-itimer (name) "Return itimer named NAME, or nil if there is none." - (check-string name) + (check-type name string) (assoc name itimer-list)) (defun read-itimer (prompt &optional initial-input) @@ -315,8 +263,9 @@ (defun delete-itimer (itimer) "Deletes ITIMER. ITIMER may be an itimer or the name of one." - (check-itimer-coerce-string itimer) - (setq itimer-list (delq itimer itimer-list))) + (if (stringp itimer) (setq itimer (get-itimer itimer))) + (check-type itimer itimer) + (setq itimer-list (delete* itimer itimer-list))) (defun start-itimer (name function value &optional restart is-idle with-args &rest function-arguments) @@ -362,15 +311,18 @@ ;; hard to imagine the user specifying these interactively nil nil )) - (check-string name) - (check-nonnegative-number value) - (if restart (check-nonnegative-number restart)) + (check-type name string) + (check-type value number) + (check-argument-range value 0 nil) + (when restart + (check-type restart number) + (check-argument-range restart 0 nil)) ;; Make proposed itimer name unique if it's not already. (let ((oname name) (num 2)) (while (get-itimer name) (setq name (format "%s<%d>" oname num)) - (itimer-increment num))) + (incf num))) (activate-itimer (list name value restart function is-idle with-args function-arguments (list 0 0 0))) (car itimer-list)) @@ -387,7 +339,7 @@ "Activate ITIMER, which was previously created with `make-itimer'. ITIMER will be added to the global list of running itimers, its FUNCTION will be called when it expires, and so on." - (check-itimer itimer) + (check-type itimer itimer) (if (memq itimer itimer-list) (error "itimer already activated")) (if (not (numberp (itimer-value itimer))) @@ -408,7 +360,7 @@ (num 1)) (while (get-itimer name) (setq name (format "%s<%d>" oname num)) - (itimer-increment num)) + (incf num)) (setcar itimer name)) ;; signal an error if the timer's name matches an already ;; activated timer. @@ -569,7 +521,7 @@ (while (and (>= opoint (point)) (< n 6)) (forward-sexp 2) (backward-sexp) - (itimer-increment n)) + (incf n)) (cond ((eq n 1) (error "Cannot change itimer name.")) ((eq n 2) 'value) ((eq n 3) 'restart) @@ -630,7 +582,7 @@ (defun itimer-edit-next-field (count) (interactive "p") (itimer-edit-beginning-of-field) - (cond ((> (itimer-signum count) 0) + (cond ((plusp count) (while (not (zerop count)) (forward-sexp) ;; wrap from eob to itimer-edit-start-marker @@ -645,8 +597,8 @@ (progn (forward-sexp 2) (backward-sexp))) - (itimer-decrement count))) - ((< (itimer-signum count) 0) + (decf count))) + ((minusp count) (while (not (zerop count)) (backward-sexp) ;; treat fields at beginning of line as if they weren't there. @@ -657,7 +609,7 @@ (progn (goto-char (point-max)) (backward-sexp))) - (itimer-increment count))))) + (incf count))))) (defun itimer-edit-previous-field (count) (interactive "p")
--- a/lisp/lib-complete.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/lib-complete.el Fri Aug 03 02:05:08 2012 +0900 @@ -118,90 +118,90 @@ (<root> <modtimes> <completion-table>)") -(defun lib-complete:better-root (ROOT1 ROOT2) - "Return non-nil if ROOT1 is a superset of ROOT2." - (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2)) - (string-match - (concat "^" (regexp-quote (file-name-nondirectory ROOT1))) - ROOT2))) - -(defun lib-complete:get-completion-table (FILE PATH FILTER) - (let* ((subdir (file-name-directory FILE)) - (root (file-name-nondirectory FILE)) - (PATH - (mapcar - (function (lambda (dir) (file-name-as-directory - (expand-file-name (or dir ""))))) - PATH)) - (key (vector PATH subdir FILTER)) - (real-dirs - (if subdir - (mapcar (function (lambda (dir) (concat dir subdir))) PATH) - PATH)) - (path-modtimes - (mapcar - (function (lambda (fn) (if fn (nth 5 (file-attributes fn))))) - real-dirs)) - (cache-entry (assoc key lib-complete:cache)) - (cache-records (cdr cache-entry))) - ;; Look for cached entry - (catch 'table - (while cache-records - (if (and - (lib-complete:better-root (nth 0 (car cache-records)) root) - (equal (nth 1 (car cache-records)) path-modtimes)) - (throw 'table (nth 2 (car cache-records)))) - (setq cache-records (cdr cache-records))) - ;; Otherwise build completions - (let ((completion-list - (progn-with-message "(building completion table...)" - (library-all-completions FILE PATH nil 'fast))) - (completion-table (make-vector 127 0))) - (while completion-list - (let ((completion - (if (or (not FILTER) - (file-directory-p (car completion-list))) - (car completion-list) - (funcall FILTER (car completion-list))))) - (if completion - (intern completion completion-table))) - (setq completion-list (cdr completion-list))) - ;; Cache the completions - (lib-complete:cache-completions key root - path-modtimes completion-table) - completion-table)))) - (defvar lib-complete:max-cache-size 40 "*Maximum number of search paths which are cached.") -(defun lib-complete:cache-completions (key root modtimes table) - (let* ((cache-entry (assoc key lib-complete:cache)) - (cache-records (cdr cache-entry)) - (new-cache-records (list (list root modtimes table)))) - (if (not cache-entry) nil - ;; Remove old cache entry - (setq lib-complete:cache (delq cache-entry lib-complete:cache)) - ;; Copy non-redundant entries from old cache entry - (while cache-records - (if (or (equal root (nth 0 (car cache-records))) - (lib-complete:better-root root (nth 0 (car cache-records)))) - nil - (setq new-cache-records - (cons (car cache-records) new-cache-records))) - (setq cache-records (cdr cache-records)))) - ;; Add entry to front of cache - (setq lib-complete:cache - (cons (cons key (nreverse new-cache-records)) lib-complete:cache)) - ;; Trim cache - (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache))) - (if tail (setcdr tail nil))))) - ;;=== Read a filename, with completion in a search path =================== (defun read-library-internal (FILE FILTER FLAG) "Don't call this." ;; Relies on read-library-internal-search-path being let-bound (declare (special read-library-internal-search-path)) + (labels + ((lib-complete:better-root (ROOT1 ROOT2) + ; Return non-nil if ROOT1 is a superset of ROOT2. + (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2)) + (string-match + (concat "^" (regexp-quote (file-name-nondirectory ROOT1))) + ROOT2))) + (lib-complete:get-completion-table (FILE PATH FILTER) + (let* ((subdir (file-name-directory FILE)) + (root (file-name-nondirectory FILE)) + (PATH + (mapcar + (function (lambda (dir) (file-name-as-directory + (expand-file-name (or dir ""))))) + PATH)) + (key (vector PATH subdir FILTER)) + (real-dirs + (if subdir + (mapcar (function (lambda (dir) (concat dir subdir))) PATH) + PATH)) + (path-modtimes + (mapcar + (function (lambda (fn) (if fn (nth 5 (file-attributes fn))))) + real-dirs)) + (cache-entry (assoc key lib-complete:cache)) + (cache-records (cdr cache-entry))) + ;; Look for cached entry + (catch 'table + (while cache-records + (if (and + (lib-complete:better-root (nth 0 (car cache-records)) root) + (equal (nth 1 (car cache-records)) path-modtimes)) + (throw 'table (nth 2 (car cache-records)))) + (setq cache-records (cdr cache-records))) + ;; Otherwise build completions + (let ((completion-list + (progn-with-message "(building completion table...)" + (library-all-completions FILE PATH nil 'fast))) + (completion-table (make-vector 127 0))) + (while completion-list + (let ((completion + (if (or (not FILTER) + (file-directory-p (car completion-list))) + (car completion-list) + (funcall FILTER (car completion-list))))) + (if completion + (intern completion completion-table))) + (setq completion-list (cdr completion-list))) + ;; Cache the completions + (lib-complete:cache-completions key root + path-modtimes completion-table) + completion-table)))) + (lib-complete:cache-completions (key root modtimes table) + (let* ((cache-entry (assoc key lib-complete:cache)) + (cache-records (cdr cache-entry)) + (new-cache-records (list (list root modtimes table)))) + (if (not cache-entry) nil + ;; Remove old cache entry + (setq lib-complete:cache (delete* cache-entry lib-complete:cache)) + ;; Copy non-redundant entries from old cache entry + (while cache-records + (if (or (equal root (nth 0 (car cache-records))) + (lib-complete:better-root root + (nth 0 (car cache-records)))) + nil + (setq new-cache-records + (cons (car cache-records) new-cache-records))) + (setq cache-records (cdr cache-records)))) + ;; Add entry to front of cache + (setq lib-complete:cache + (cons (cons key (nreverse new-cache-records)) + lib-complete:cache)) + ;; Trim cache + (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache))) + (if tail (setcdr tail nil)))))) (let ((completion-table (lib-complete:get-completion-table FILE read-library-internal-search-path FILTER))) @@ -212,7 +212,7 @@ ((eq FLAG nil) (try-completion FILE completion-table nil)) ((eq FLAG t) (all-completions FILE completion-table nil)) ((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t)) - ))) + )))) (defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH FULL FILTER)
--- a/lisp/loadhist.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/loadhist.el Fri Aug 03 02:05:08 2012 +0900 @@ -185,7 +185,7 @@ ((consp x) ;; Remove any feature names that this file provided. (if (eq (car x) 'provide) - (setq features (delq (cdr x) features)) + (setq features (delete* (cdr x) features)) (if (eq (car x) 'module) (setq unloading-module t)))) ((and (boundp x) @@ -201,7 +201,7 @@ (cdr flist))) ;; Delete the load-history element for this file. (let ((elt (assoc file load-history))) - (setq load-history (delq elt load-history))) + (setq load-history (delete* elt load-history))) ;; If it is a module, really unload it. (if unloading-module (declare-fboundp (unload-module (symbol-name feature))))))
--- a/lisp/menubar-items.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/menubar-items.el Fri Aug 03 02:05:08 2012 +0900 @@ -1806,7 +1806,7 @@ (funcall fn buffer) (funcall fn buffer n)))) (if complex-buffers-menu-p - (delq nil + (delete* nil (list line (vector "S%_witch to Buffer" (list buffers-menu-switch-to-buffer-function
--- a/lisp/menubar.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/menubar.el Fri Aug 03 02:05:08 2012 +0900 @@ -178,35 +178,36 @@ the item found. If the item does not exist, the car of the returned value is nil. If some menu in the ITEM-PATH-LIST does not exist, an error is signalled." - (find-menu-item-1 menubar item-path-list)) - -(defun find-menu-item-1 (menubar item-path-list &optional parent) - (check-argument-type 'listp item-path-list) - (if (not (consp menubar)) - nil - (let ((rest menubar) - result) - (when (stringp (car rest)) - (setq rest (cdr rest))) - (while (keywordp (car rest)) - (setq rest (cddr rest))) - (while rest - (if (and (car rest) - (stringp (car item-path-list)) - (= 0 (compare-menu-text (car item-path-list) - (menu-item-text (car rest))))) - (setq result (car rest) - rest nil) - (setq rest (cdr rest)))) - (if (cdr item-path-list) - (cond ((consp result) - (find-menu-item-1 (cdr result) (cdr item-path-list) result)) - (result - (signal 'error (list (gettext "not a submenu") result))) - (t - (signal 'error (list (gettext "no such submenu") - (car item-path-list))))) - (cons result parent))))) + (labels + ((find-menu-item-1 (menubar item-path-list &optional parent) + (check-argument-type 'listp item-path-list) + (if (not (consp menubar)) + nil + (let ((rest menubar) + result) + (when (stringp (car rest)) + (setq rest (cdr rest))) + (while (keywordp (car rest)) + (setq rest (cddr rest))) + (while rest + (if (and (car rest) + (stringp (car item-path-list)) + (= 0 (compare-menu-text (car item-path-list) + (menu-item-text (car rest))))) + (setq result (car rest) + rest nil) + (setq rest (cdr rest)))) + (if (cdr item-path-list) + (cond ((consp result) + (find-menu-item-1 (cdr result) (cdr item-path-list) + result)) + (result + (signal 'error (list (gettext "not a submenu") result))) + (t + (signal 'error (list (gettext "no such submenu") + (car item-path-list))))) + (cons result parent)))))) + (find-menu-item-1 menubar item-path-list))) (defun add-menu-item-1 (leaf-p menu-path new-item before in-menu) ;; This code looks like it could be cleaned up some more @@ -351,8 +352,8 @@ ;; the menubar is the only special case, because other menus begin ;; with their name. (if (eq parent current-menubar) - (setq current-menubar (delq item parent)) - (delq item parent)) + (setq current-menubar (delete* item parent)) + (delete* item parent)) (set-menubar-dirty-flag) item)))
--- a/lisp/minibuf.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/minibuf.el Fri Aug 03 02:05:08 2012 +0900 @@ -58,18 +58,11 @@ :group 'minibuffer) (defvar minibuffer-completion-table nil - "Alist or obarray used for completion in the minibuffer. -This becomes the ALIST argument to `try-completion' and `all-completions'. + "List, hash table, function or obarray used for minibuffer completion. -The value may alternatively be a function, which is given three arguments: - STRING, the current buffer contents; - PREDICATE, the predicate for filtering possible matches; - CODE, which says what kind of things to do. -CODE can be nil, t or `lambda'. -nil means to return the best completion of STRING, nil if there is none, - or t if it is already a unique completion. -t means to return a list of all possible completions of STRING. -`lambda' means to return t if STRING is a valid completion as it stands.") +This becomes the COLLECTION argument to `try-completion', `all-completions' +and `test-completion'; see the documentation of those functions for how +values are interpreted.") (defvar minibuffer-completion-predicate nil "Within call to `completing-read', this holds the PREDICATE argument.") @@ -621,56 +614,6 @@ (setq unread-command-event (character-to-event (quit-char)) quit-flag nil))))) - -;; Determines whether buffer-string is an exact completion -(defun exact-minibuffer-completion-p (buffer-string) - (cond ((not minibuffer-completion-table) - ;; Empty alist - nil) - ((vectorp minibuffer-completion-table) - (let ((tem (intern-soft buffer-string - minibuffer-completion-table))) - (if (or tem - (and (string-equal buffer-string "nil") - ;; intern-soft loses for 'nil - (catch 'found - (mapatoms #'(lambda (s) - (if (string-equal - (symbol-name s) - buffer-string) - (throw 'found t))) - minibuffer-completion-table) - nil))) - (if minibuffer-completion-predicate - (funcall minibuffer-completion-predicate - tem) - t) - nil))) - ((and (consp minibuffer-completion-table) - ;;#### Emacs-Lisp truly sucks! - ;; lambda, autoload, etc - (not (symbolp (car minibuffer-completion-table)))) - (if (not completion-ignore-case) - (assoc buffer-string minibuffer-completion-table) - (let ((s (upcase buffer-string)) - (tail minibuffer-completion-table) - tem) - (while tail - (setq tem (car (car tail))) - (if (or (equal tem buffer-string) - (equal tem s) - (if tem (equal (upcase tem) s))) - (setq s 'win - tail nil) ;exit - (setq tail (cdr tail)))) - (eq s 'win)))) - (t - (funcall minibuffer-completion-table - buffer-string - minibuffer-completion-predicate - 'lambda))) - ) - ;; 0 'none no possible completion ;; 1 'unique was already an exact and unique completion ;; 3 'exact was already an exact (but nonunique) completion @@ -693,7 +636,8 @@ (erase-buffer) (insert completion) (setq buffer-string completion))) - (if (exact-minibuffer-completion-p buffer-string) + (if (test-completion buffer-string minibuffer-completion-table + minibuffer-completion-predicate) ;; An exact completion was possible (if completedp ;; Since no callers need to know the difference, don't bother @@ -752,20 +696,18 @@ ;;;; completing-read -(defun completing-read (prompt table - &optional predicate require-match - initial-contents history default) +(defun completing-read (prompt collection &optional predicate require-match + initial-contents history default) "Read a string in the minibuffer, with completion. PROMPT is a string to prompt with; normally it ends in a colon and a space. -TABLE is an alist whose elements' cars are strings, or an obarray. -TABLE can also be a function which does the completion itself. -PREDICATE limits completion to a subset of TABLE. -See `try-completion' and `all-completions' for more details - on completion, TABLE, and PREDICATE. +COLLECTION is a set of objects that are the possible completions. +PREDICATE limits completion to a subset of COLLECTION. +See `try-completion' and `all-completions' for details of COLLECTION, + PREDICATE, and completion in general. If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless - the input is (or completes to) an element of TABLE or is null. + the input is (or completes to) an element of COLLECTION or is null. If it is also not t, Return does not exit if it does non-null completion. If INITIAL-CONTENTS is non-nil, insert it in the minibuffer initially. If it is (STRING . POSITION), the initial input @@ -785,7 +727,7 @@ Completion ignores case if the ambient value of `completion-ignore-case' is non-nil." - (let ((minibuffer-completion-table table) + (let ((minibuffer-completion-table collection) (minibuffer-completion-predicate predicate) (minibuffer-completion-confirm (if (eq require-match 't) nil t)) (last-exact-completion nil) @@ -862,7 +804,8 @@ (let ((buffer-string (buffer-string))) ;; Short-cut -- don't call minibuffer-do-completion if we already ;; have an (possibly nonunique) exact completion. - (if (exact-minibuffer-completion-p buffer-string) + (if (test-completion buffer-string minibuffer-completion-table + minibuffer-completion-predicate) (throw 'exit nil)) (let ((status (minibuffer-do-completion buffer-string))) (if (or (eq status 'unique) @@ -893,7 +836,8 @@ (if (not minibuffer-confirm-incomplete) (throw 'exit nil)) (let ((buffer-string (buffer-string))) - (if (exact-minibuffer-completion-p buffer-string) + (if (test-completion buffer-string minibuffer-completion-table + minibuffer-completion-predicate) (throw 'exit nil)) (let ((completion (if (not minibuffer-completion-table) t @@ -1092,6 +1036,9 @@ ;; prefix for other completions. This means that we ;; can't just do the obvious thing, (eq t ;; (try-completion ...)). + ;; + ;; Could be reasonable to use #'test-completion + ;; instead. Aidan Kehoe, Mo 14 Mai 2012 08:17:10 IST (let (comp) (if (and filename-kludge-p ;; #### evil evil evil evil @@ -1479,8 +1426,7 @@ default)) prompt)) (alist (mapcar #'(lambda (b) (cons (buffer-name b) b)) - (remove-if (lambda (elt) (member elt exclude)) - (buffer-list)))) + (set-difference (buffer-list) exclude))) result) (while (progn (setq result (completing-read prompt alist nil require-match @@ -2187,7 +2133,7 @@ to build a completion table. On TTY devices, this uses `tty-color-list'. On mswindows devices, this uses `mswindows-color-list'." - (let ((table (read-color-completion-table))) + (let ((table (color-list))) (completing-read prompt table nil (and table must-match) initial-contents)))
--- a/lisp/msw-font-menu.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/msw-font-menu.el Fri Aug 03 02:05:08 2012 +0900 @@ -118,7 +118,7 @@ done) (setq sizes (cons (car common) sizes))) (setq common (cdr common))) - (setq sizes (delq 0 sizes)))) + (setq sizes (delete* 0 sizes)))) (setq families (sort families 'string-lessp) weights (sort weights 'string-lessp)
--- a/lisp/mule/make-coding-system.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/mule/make-coding-system.el Fri Aug 03 02:05:08 2012 +0900 @@ -90,7 +90,7 @@ (loop for char across decode-table do (pushnew (char-charset char) known-charsets)) - (setq known-charsets (delq 'ascii known-charsets)) + (setq known-charsets (delete* 'ascii known-charsets)) (loop for known-charset in known-charsets do
--- a/lisp/mule/misc-lang.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/mule/misc-lang.el Fri Aug 03 02:05:08 2012 +0900 @@ -41,4 +41,26 @@ short-name "IPA" long-name "IPA")) +;; XEmacs; these are Latin, it's not useful to put word boundaries between +;; them and ASCII. +(modify-category-entry 'ipa ?l nil t) + +;; XEmacs; why are these Latin? See the following: +;; +;; (let ((scripts +;; (mapcar #'(lambda (character) +;; (car +;; (split-string +;; (cadr (assoc "Name" (describe-char-unicode-data +;; character)))))) +;; (loop +;; for i from 33 to 127 +;; if (not (eql -1 (char-to-unicode (make-char 'ipa i)))) +;; nconc (list (make-char 'ipa i)))))) +;; (mapcar #'(lambda (script) +;; (cons script (count script scripts :test #'equal))) +;; (remove-duplicates scripts :test #'equal))) +;; => (("GREEK" . 1) ("LATIN" . 55) ("MODIFIER" . 3)) + + ;;; misc-lang.el ends here
--- a/lisp/mule/mule-category.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/mule/mule-category.el Fri Aug 03 02:05:08 2012 +0900 @@ -252,6 +252,7 @@ (chinese-big5-1 ?t) (chinese-big5-2 ?t) (korean-ksc5601 ?h "Hangul (Korean) 2-byte character set") + (jit-ucs-charset-0 ?J "Just-in-time-allocated Unicode character") ) "List of predefined categories. Each element is a list of a charset, a designator, and maybe a doc string.") @@ -275,7 +276,18 @@ ;;; Setting word boundary. (setq word-combining-categories - '((?l . ?l))) + ;; XEmacs; we should change to defining scripts, as does GNU, once + ;; unicode-internal is the default, and placing word boundaries + ;; between different scripts, not different charsets, by default. + ;; Then we can remove the jit-ucs-charset-0 entry above and all the + ;; entries containing ?J in this list. + ;; + ;; These entries are a bit heuristic, working on the assumption that + ;; characters that will be just-in-time-allocated will not be East + ;; Asian in XEmacs, and there's also no mechanism to apply the ?J + ;; category to further newly-created JIT categories. + '((?l . ?l) (?J . ?l) (?l . ?J) (?J . ?y) (?y . ?J) (?J . ?b) (?b . ?J) + (?J . ?g) (?J . ?w) (?w . ?J))) (setq word-separating-categories ; (2-byte character sets) '((?A . ?K) ; Alpha numeric - Katakana
--- a/lisp/newcomment.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/newcomment.el Fri Aug 03 02:05:08 2012 +0900 @@ -577,12 +577,14 @@ (concat lpad s (when multi (make-string n (aref str (1- (match-end 1))))) rpad) ;; construct a regexp that would match anything from just S ;; to any possible output of this function for any N. - (concat (mapconcat (lambda (c) (concat (regexp-quote (string c)) "?")) - lpad "") ;padding is not required - (regexp-quote s) - (when multi "+") ;the last char of S might be repeated - (mapconcat (lambda (c) (concat (regexp-quote (string c)) "?")) - rpad "")))))) ;padding is not required + (labels + ((regexp-quote-with-? (c) (concat (regexp-quote (string c)) "?"))) + (concat (mapconcat #'regexp-quote-with-? + lpad "") ;padding is not required + (regexp-quote s) + (when multi "+") ;the last char of S might be repeated + (mapconcat #'regexp-quote-with-? + rpad ""))))))) ;padding is not required (defun comment-padleft (str &optional n) "Construct a string composed of `comment-padding' plus STR.
--- a/lisp/next-error.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/next-error.el Fri Aug 03 02:05:08 2012 +0900 @@ -137,14 +137,14 @@ (or ;; 1. If one window on the selected frame displays such buffer, return it. (let ((window-buffers - (delete-dups - (delq nil (mapcar (lambda (w) - (if (next-error-buffer-p - (window-buffer w) - avoid-current - extra-test-inclusive extra-test-exclusive) - (window-buffer w))) - (window-list)))))) + (delete-duplicates + (mapcan #'(lambda (w) + (if (next-error-buffer-p + (window-buffer w) + avoid-current + extra-test-inclusive extra-test-exclusive) + (list (window-buffer w)))) + (window-list))))) (if (eq (length window-buffers) 1) (car window-buffers))) ;; 2. If next-error-last-buffer is an acceptable buffer, use that.
--- a/lisp/obsolete.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/obsolete.el Fri Aug 03 02:05:08 2012 +0900 @@ -410,7 +410,8 @@ "Return a list of charsets in the STRING except ascii. It might be available for compatibility with Mule 2.3, because its `find-charset-string' ignores ASCII charset." - (delq 'ascii (and-fboundp 'charsets-in-string (charsets-in-string string)))) + (delete* 'ascii + (and-fboundp 'charsets-in-string (charsets-in-string string)))) (make-obsolete 'find-non-ascii-charset-string "use (delq 'ascii (charsets-in-string STRING)) instead.") @@ -418,8 +419,8 @@ "Return a list of charsets except ascii in the region between START and END. It might be available for compatibility with Mule 2.3, because its `find-charset-string' ignores ASCII charset." - (delq 'ascii (and-fboundp 'charsets-in-region - (charsets-in-region start end)))) + (delete* 'ascii (and-fboundp 'charsets-in-region + (charsets-in-region start end)))) (make-obsolete 'find-non-ascii-charset-region "use (delq 'ascii (charsets-in-region START END)) instead.")
--- a/lisp/occur.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/occur.el Fri Aug 03 02:05:08 2012 +0900 @@ -365,24 +365,21 @@ (occur-read-primary-args))) (when bufregexp (occur-1 regexp nlines - (delq nil - (mapcar (lambda (buf) - (when (and (buffer-file-name buf) - (string-match bufregexp - (buffer-file-name buf))) - buf)) - (buffer-list)))))) + (mapcan #'(lambda (buf) + (when (and (buffer-file-name buf) + (string-match bufregexp + (buffer-file-name buf))) + (list buf))) + (buffer-list))))) (defun occur-1 (regexp nlines bufs &optional buf-name) (unless buf-name (setq buf-name "*Occur*")) (let (occur-buf - (active-bufs (delq nil (mapcar #'(lambda (buf) - (when (buffer-live-p buf) buf)) - bufs)))) + (active-bufs (remove-if-not #'buffer-live-p bufs))) ;; Handle the case where one of the buffers we're searching is the ;; output buffer. Just rename it. - (when (member buf-name (mapcar 'buffer-name active-bufs)) + (when (position buf-name active-bufs :test #'equal :key #'buffer-name) (with-current-buffer (get-buffer buf-name) (rename-uniquely)))
--- a/lisp/packages.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/packages.el Fri Aug 03 02:05:08 2012 +0900 @@ -85,26 +85,15 @@ "Load path for packages last in the load path.") (defun packages-package-hierarchy-directory-names () - "Returns a list package hierarchy directory names. + "Returns a list of package hierarchy directory names. These are the valid immediate directory names of package directories, directories with higher priority first" - (delq nil `("site-packages" - ,(when (featurep 'mule) "mule-packages") - "xemacs-packages"))) - -(defun package-get-key-1 (info key) - "Locate keyword `key' in list." - (cond ((null info) - nil) - ((eq (car info) key) - (nth 1 info)) - (t (package-get-key-1 (cddr info) key)))) + `("site-packages" ,@(when (featurep 'mule) '("mule-packages")) + "xemacs-packages")) (defun package-get-key (name key) "Get info `key' from package `name'." - (let ((info (assq name packages-package-list))) - (when info - (package-get-key-1 (cdr info) key)))) + (getf (cdr (assq name packages-package-list)) key)) (defun package-provide (name &rest attributes) (let ((info (if (and attributes (floatp (car attributes)))
--- a/lisp/process.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/process.el Fri Aug 03 02:05:08 2012 +0900 @@ -707,7 +707,8 @@ (cond ((string-match pattern (car scan)) (setq found t) (if (eq nil value) - (setq process-environment (delq (car scan) process-environment)) + (setq process-environment + (delete* (car scan) process-environment)) (setcar scan (concat variable "=" value))) (setq scan nil))) (setq scan (cdr scan)))
--- a/lisp/simple.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/simple.el Fri Aug 03 02:05:08 2012 +0900 @@ -407,12 +407,6 @@ (if (eq arg '-) (setq arg -1)) (kill-region (point) (+ (point) arg))) -;; Internal subroutine of backward-delete-char -(defun kill-backward-chars (arg) - (if (listp arg) (setq arg (car arg))) - (if (eq arg '-) (setq arg -1)) - (kill-region (point) (- (point) arg))) - (defun backward-delete-char-untabify (arg &optional killp) "Delete characters backward, changing tabs into spaces. Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil. @@ -824,8 +818,7 @@ percent narrowed-details col hscroll) (message "Char: %s (%s %s) point=%d of %d(%d%%)%s column %d %s" (text-char-description char) unicode-string - (mapconcat (lambda (arg) (format "%S" arg)) - (split-char char) " ") + (mapconcat #'prin1-to-string (split-char char) " ") pos total percent narrowed-details col hscroll))))) @@ -958,7 +951,7 @@ (if (fixnump (car tail)) (progn (setq done t) - (setq buffer-undo-list (delq (car tail) buffer-undo-list)))) + (setq buffer-undo-list (delete* (car tail) buffer-undo-list)))) (setq tail (cdr tail)))) (and modified (not (buffer-modified-p)) (delete-auto-save-file-if-necessary recent-save))) @@ -2100,7 +2093,7 @@ (loop for keysym in motion-keys-for-shifted-motion with key = (event-key last-input-event) - with mods = (delq 'shift (event-modifiers last-input-event)) + with mods = (delete* 'shift (event-modifiers last-input-event)) with char-list = '(?a) ;; Some random character; the list will be ;; modified in the constants vector over ;; time. @@ -4766,8 +4759,8 @@ (cond ((featurep 'xemacs) "XEmacs") (t "Emacs"))) -(defun debug-print-1 (&rest args) - "Send a debugging-type string to standard output. +(defun debug-print (&rest args) + "Send a string to the debugging output. If the first argument is a string, it is considered to be a format specifier if there are sufficient numbers of other args, and the string is formatted using (apply #'format args). Otherwise, each argument is printed @@ -4790,15 +4783,6 @@ (incf i)) (terpri))))) -(defun debug-print (&rest args) - "Send a string to the debugging output. -If the first argument is a string, it is considered to be a format -specifier if there are sufficient numbers of other args, and the string is -formatted using (apply #'format args). Otherwise, each argument is printed -individually in a numbered list." - (let ((standard-output 'external-debugging-output)) - (apply #'debug-print-1 args))) - (defun debug-backtrace () "Send a backtrace to the debugging output." (let ((standard-output 'external-debugging-output))
--- a/lisp/sound.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/sound.el Fri Aug 03 02:05:08 2012 +0900 @@ -174,8 +174,7 @@ (erase-buffer)) (and buf (kill-buffer buf))) (let ((old (assq sound-name sound-alist))) - ;; some conses in sound-alist might have been dumped with emacs. - (if old (setq sound-alist (delq old (copy-sequence sound-alist))))) + (if old (setq sound-alist (remove* old sound-alist)))) (setq sound-alist (cons (nconc (list sound-name) (if (and volume (not (eq 0 volume)))
--- a/lisp/subr.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/subr.el Fri Aug 03 02:05:08 2012 +0900 @@ -975,9 +975,9 @@ "Return INTEGER converted to a bit vector. Optional argument MINLENGTH gives a minimum length for the returned vector. If MINLENGTH is not given, zero high-order bits will be ignored." - (check-argument-type #'integerp integer) + (check-type integer integer) (setq minlength (or minlength 0)) - (check-nonnegative-number minlength) + (check-type minlength natnum) (read (format (format "#*%%0%db" minlength) integer))) ;; XEmacs addition. @@ -1030,97 +1030,70 @@ (replace (the string string) obj :start1 idx) (prog1 string (aset string idx obj)))) -;; From FSF 21.1; ELLIPSES is XEmacs addition. - -(defun truncate-string-to-width (str end-column &optional start-column padding - ellipses) +;; XEmacs; this is in mule-util in GNU. See tests/automated/mule-tests.el for +;; the tests that Colin Walters includes in that file. +(defun truncate-string-to-width (str end-column + &optional start-column padding ellipsis) "Truncate string STR to end at column END-COLUMN. -The optional 3rd arg START-COLUMN, if non-nil, specifies -the starting column; that means to return the characters occupying -columns START-COLUMN ... END-COLUMN of STR. +The optional 3rd arg START-COLUMN, if non-nil, specifies the starting +column; that means to return the characters occupying columns +START-COLUMN ... END-COLUMN of STR. Both END-COLUMN and START-COLUMN +are specified in terms of character display width in the current +buffer; see also `char-width'. -The optional 4th arg PADDING, if non-nil, specifies a padding character -to add at the end of the result if STR doesn't reach column END-COLUMN, -or if END-COLUMN comes in the middle of a character in STR. -PADDING is also added at the beginning of the result -if column START-COLUMN appears in the middle of a character in STR. +The optional 4th arg PADDING, if non-nil, specifies a padding +character (which should have a display width of 1) to add at the end +of the result if STR doesn't reach column END-COLUMN, or if END-COLUMN +comes in the middle of a character in STR. PADDING is also added at +the beginning of the result if column START-COLUMN appears in the +middle of a character in STR. If PADDING is nil, no padding is added in these cases, so the resulting string may be narrower than END-COLUMN. -BUG: Currently assumes that the padding character is of width one. You -will get weird results if not. - -If ELLIPSES is non-nil, add ellipses (specified by ELLIPSES if a string, -else `...') if STR extends past END-COLUMN. The ellipses will be added in -such a way that the total string occupies no more than END-COLUMN columns --- i.e. if the string goes past END-COLUMN, it will be truncated somewhere -short of END-COLUMN so that, with the ellipses added (and padding, if the -proper place to truncate the string would be in the middle of a character), -the string occupies exactly END-COLUMN columns." +If ELLIPSIS is non-nil, it should be a string which will replace the +end of STR (including any padding) if it extends beyond END-COLUMN, +unless the display width of STR is equal to or less than the display +width of ELLIPSIS. If it is non-nil and not a string, then ELLIPSIS +defaults to \"...\"." (or start-column (setq start-column 0)) - (let ((len (length str)) + (when (and ellipsis (not (stringp ellipsis))) + (setq ellipsis "...")) + (let ((str-len (length str)) + (str-width (string-width str)) + (ellipsis-width (if ellipsis (string-width ellipsis) 0)) (idx 0) (column 0) (head-padding "") (tail-padding "") ch last-column last-idx from-idx) - - ;; find the index of START-COLUMN; bail out if end of string reached. - (condition-case nil - (while (< column start-column) - (setq ch (aref str idx) - column (+ column (char-width ch)) - idx (1+ idx))) - (args-out-of-range (setq idx len))) + (while (and (< column start-column) (< idx str-len)) + (setq ch (aref str idx) + column (+ column (char-width ch)) + idx (1+ idx))) (if (< column start-column) - ;; if string ends before START-COLUMN, return either a blank string - ;; or a string entirely padded. - (if padding (make-string (- end-column start-column) padding) "") - (if (and padding (> column start-column)) - (setq head-padding (make-string (- column start-column) padding))) + (if padding (make-string end-column padding) "") + (when (and padding (> column start-column)) + (setq head-padding (make-string (- column start-column) padding))) (setq from-idx idx) - ;; If END-COLUMN is before START-COLUMN, then bail out. - (if (< end-column column) - (setq idx from-idx ellipses "") - - ;; handle ELLIPSES - (cond ((null ellipses) (setq ellipses "")) - ((if (<= (string-width str) end-column) - ;; string fits, no ellipses - (setq ellipses ""))) - (t - ;; else, insert default value and ... - (or (stringp ellipses) (setq ellipses "...")) - ;; ... take away the width of the ellipses from the - ;; destination. do all computations with new, shorter - ;; width. the padding computed will get us exactly up to - ;; the shorted width, which is right -- it just gets added - ;; to the right of the ellipses. - (setq end-column (- end-column (string-width ellipses))))) - - ;; find the index of END-COLUMN; bail out if end of string reached. - (condition-case nil - (while (< column end-column) - (setq last-column column - last-idx idx - ch (aref str idx) - column (+ column (char-width ch)) - idx (1+ idx))) - (args-out-of-range (setq idx len))) - ;; if we went too far (stopped in middle of character), back up. - (if (> column end-column) - (setq column last-column idx last-idx)) - ;; compute remaining padding - (if (and padding (< column end-column)) - (setq tail-padding (make-string (- end-column column) padding)))) - ;; get substring ... - (setq str (substring str from-idx idx)) - ;; and construct result - (if padding - (concat head-padding str tail-padding ellipses) - (concat str ellipses))))) - + (when (>= end-column column) + (if (and (< end-column str-width) + (> str-width ellipsis-width)) + (setq end-column (- end-column ellipsis-width)) + (setq ellipsis "")) + (while (and (< column end-column) (< idx str-len)) + (setq last-column column + last-idx idx + ch (aref str idx) + column (+ column (char-width ch)) + idx (1+ idx))) + (when (> column end-column) + (setq column last-column + idx last-idx)) + (when (and padding (< column end-column)) + (setq tail-padding (make-string (- end-column column) padding)))) + (concat head-padding (substring str from-idx idx) + tail-padding ellipsis)))) ;; alist/plist functions (defun plist-to-alist (plist)
--- a/lisp/wid-edit.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/wid-edit.el Fri Aug 03 02:05:08 2012 +0900 @@ -2332,7 +2332,7 @@ (defun widget-field-value-delete (widget) "Remove the widget from the list of active editing fields." - (setq widget-field-list (delq widget widget-field-list)) + (setq widget-field-list (delete* widget widget-field-list)) ;; These are nil if the :format string doesn't contain `%v'. (let ((extent (widget-get widget :field-extent))) (when extent @@ -2676,7 +2676,7 @@ (let ((vals (widget-match-inline answer values))) (setq found (append found (car vals)) values (cdr vals) - args (delq answer args)))) + args (delete* answer args)))) (greedy (setq rest (append rest (list (car values))) values (cdr values))) @@ -2697,7 +2697,7 @@ (let ((match (widget-match-inline answer vals))) (setq found (cons (cons answer (car match)) found) vals (cdr match) - args (delq answer args)))) + args (delete* answer args)))) (greedy (setq vals (cdr vals))) (t @@ -3091,7 +3091,7 @@ buttons (cdr buttons)) (when (eq (widget-get button :widget) child) (widget-put widget - :buttons (delq button (widget-get widget :buttons))) + :buttons (delete* button (widget-get widget :buttons))) (widget-delete button)))) (let ((entry-from (widget-get child :entry-from)) (entry-to (widget-get child :entry-to)) @@ -3102,7 +3102,7 @@ (delete-region entry-from entry-to) (set-marker entry-from nil) (set-marker entry-to nil)) - (widget-put widget :children (delq child (widget-get widget :children)))) + (widget-put widget :children (delete* child (widget-get widget :children)))) (widget-setup) (widget-apply widget :notify widget))
--- a/lisp/widget.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/widget.el Fri Aug 03 02:05:08 2012 +0900 @@ -34,19 +34,6 @@ ;;; Code: -;; Neither XEmacs, nor latest GNU Emacs need this -- provided for -;; compatibility. -;; (defalias 'define-widget-keywords 'ignore) - -(defmacro define-widget-keywords (&rest keys) - "This doesn't do anything in Emacs 20 or XEmacs." - `(eval-and-compile - (let ((keywords (quote ,keys))) - (while keywords - (or (boundp (car keywords)) - (set (car keywords) (car keywords))) - (setq keywords (cdr keywords)))))) - (defun define-widget (name class doc &rest args) "Define a new widget type named NAME from CLASS.
--- a/lisp/window-xemacs.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/window-xemacs.el Fri Aug 03 02:05:08 2012 +0900 @@ -756,18 +756,11 @@ :type 'integer :group 'windows) -;; Deiconify the frame containing the window WINDOW, then return WINDOW. - -(defun display-buffer-1 (window) - (if (frame-iconified-p (window-frame window)) - (make-frame-visible (window-frame window))) - window) - ;; Can you believe that all of this crap was formerly in C? ;; Praise Jesus that it's not there any more. (defun display-buffer (buffer &optional not-this-window-p override-frame - shrink-to-fit) + shrink-to-fit) "Make BUFFER appear in some window on the current frame, but don't select it. BUFFER can be a buffer or a buffer name. If BUFFER is shown already in some window in the current frame, @@ -797,271 +790,275 @@ Returns the window displaying BUFFER." (interactive "BDisplay buffer:\nP") - (let ((wconfig (current-window-configuration)) - (result - ;; We just simulate a `return' in C. This function is way ugly - ;; and does `returns' all over the place and there's no sense - ;; in trying to rewrite it to be more Lispy. - (catch 'done - (let (window old-frame target-frame explicit-frame shrink-it) - (setq old-frame (or (last-nonminibuf-frame) (selected-frame))) - (setq buffer (get-buffer buffer)) - (check-argument-type 'bufferp buffer) + (let ((wconfig (current-window-configuration))) + (prog1 + ;; We just simulate a `return' in C. This function is way + ;; ugly and does `returns' all over the place and there's + ;; no sense in trying to rewrite it to be more Lispy. + (block nil + (labels + ((display-buffer-1 (window) + ;; Deiconify the frame containing the window WINDOW, then + ;; return WINDOW. + (if (frame-iconified-p (window-frame window)) + (make-frame-visible (window-frame window))) + window)) + (let (window old-frame target-frame explicit-frame shrink-it) + (setq old-frame (or (last-nonminibuf-frame) (selected-frame))) + (setq buffer (get-buffer buffer)) + (check-argument-type 'bufferp buffer) - (setq explicit-frame - (if pre-display-buffer-function - (funcall pre-display-buffer-function buffer - not-this-window-p - override-frame - shrink-to-fit))) - - ;; Give the user the ability to completely reimplement - ;; this function via the `display-buffer-function'. - (if display-buffer-function - (throw 'done - (funcall display-buffer-function buffer - not-this-window-p - override-frame - shrink-to-fit))) + (setq explicit-frame + (if pre-display-buffer-function + (funcall pre-display-buffer-function buffer + not-this-window-p + override-frame + shrink-to-fit))) - ;; If the buffer has a dedicated frame, that takes - ;; precedence over the current frame, and over what the - ;; pre-display-buffer-function did. - (let ((dedi (buffer-dedicated-frame buffer))) - (if (frame-live-p dedi) (setq explicit-frame dedi))) + ;; Give the user the ability to completely reimplement + ;; this function via the `display-buffer-function'. + (if display-buffer-function + (return (funcall display-buffer-function buffer + not-this-window-p + override-frame + shrink-to-fit))) - ;; if override-frame is supplied, that takes precedence over - ;; everything. This is gonna look bad if the - ;; pre-display-buffer-function raised some other frame - ;; already. - (if override-frame - (progn - (check-argument-type 'frame-live-p override-frame) - (setq explicit-frame override-frame))) + ;; If the buffer has a dedicated frame, that takes + ;; precedence over the current frame, and over what the + ;; pre-display-buffer-function did. + (let ((dedi (buffer-dedicated-frame buffer))) + (if (frame-live-p dedi) (setq explicit-frame dedi))) - (setq target-frame - (or explicit-frame - (last-nonminibuf-frame) - (selected-frame))) + ;; if override-frame is supplied, that takes precedence over + ;; everything. This is gonna look bad if the + ;; pre-display-buffer-function raised some other frame already. + (if override-frame + (progn + (check-argument-type 'frame-live-p override-frame) + (setq explicit-frame override-frame))) - ;; If we have switched frames, then set not-this-window-p - ;; to false. Switching frames means that selected-window - ;; is no longer the same as it was on entry -- it's the - ;; selected-window of target_frame instead of old_frame, - ;; so it's a fine candidate for display. - (if (not (eq old-frame target-frame)) - (setq not-this-window-p nil)) + (setq target-frame + (or explicit-frame + (last-nonminibuf-frame) + (selected-frame))) - ;; if it's in the selected window, and that's ok, then we're done. - (if (and (not not-this-window-p) - (eq buffer (window-buffer (selected-window)))) - (throw 'done (display-buffer-1 (selected-window)))) + ;; If we have switched frames, then set not-this-window-p to + ;; false. Switching frames means that selected-window is no + ;; longer the same as it was on entry -- it's the + ;; selected-window of target_frame instead of old_frame, so + ;; it's a fine candidate for display. + (if (not (eq old-frame target-frame)) + (setq not-this-window-p nil)) - ;; See if the user has specified this buffer should appear - ;; in the selected window. - - (if not-this-window-p - nil + ;; if it's in the selected window, and that's ok, then we're + ;; done. + (if (and (not not-this-window-p) + (eq buffer (window-buffer (selected-window)))) + (return (display-buffer-1 (selected-window)))) - (if (or (member (buffer-name buffer) same-window-buffer-names) - (assoc (buffer-name buffer) same-window-buffer-names)) - (progn - (switch-to-buffer buffer) - (throw 'done (display-buffer-1 (selected-window))))) + ;; See if the user has specified this buffer should + ;; appear in the selected window. - (let ((tem same-window-regexps)) - (while tem - (let ((car (car tem))) - (if (or - (and (stringp car) - (string-match car (buffer-name buffer))) - (and (consp car) (stringp (car car)) - (string-match (car car) (buffer-name buffer)))) - (progn - (switch-to-buffer buffer) - (throw 'done (display-buffer-1 - (selected-window)))))) - (setq tem (cdr tem))))) + (if not-this-window-p + nil + (if (or (member (buffer-name buffer) same-window-buffer-names) + (assoc (buffer-name buffer) same-window-buffer-names)) + (progn + (switch-to-buffer buffer) + (return (display-buffer-1 (selected-window))))) + + (let ((tem same-window-regexps)) + (while tem + (let ((car (car tem))) + (if (or + (and (stringp car) + (string-match car (buffer-name buffer))) + (and (consp car) (stringp (car car)) + (string-match (car car) (buffer-name buffer)))) + (progn + (switch-to-buffer buffer) + (return (display-buffer-1 (selected-window)))))) + (setq tem (cdr tem))))) - ;; If pop-up-frames, look for a window showing BUFFER on - ;; any visible or iconified frame. Otherwise search only - ;; the current frame. - (if (and (not explicit-frame) - (or pop-up-frames (not (last-nonminibuf-frame)))) - (setq target-frame 0)) + ;; If pop-up-frames, look for a window showing BUFFER + ;; on any visible or iconified frame. Otherwise search + ;; only the current frame. + (if (and (not explicit-frame) + (or pop-up-frames (not (last-nonminibuf-frame)))) + (setq target-frame 0)) - ;; Otherwise, find some window that it's already in, and - ;; return that, unless that window is the selected window - ;; and that isn't ok. What a contorted mess! - (setq window (or (if (not explicit-frame) - ;; search the selected frame - ;; first if the user didn't - ;; specify an explicit frame. - (get-buffer-window buffer nil)) - (get-buffer-window buffer target-frame))) - (if (and window - (or (not not-this-window-p) - (not (eq window (selected-window))))) - (throw 'done (display-buffer-1 window))) + ;; Otherwise, find some window that it's already in, + ;; and return that, unless that window is the selected + ;; window and that isn't ok. What a contorted mess! + (setq window (or (if (not explicit-frame) + ;; search the selected frame + ;; first if the user didn't + ;; specify an explicit frame. + (get-buffer-window buffer nil)) + (get-buffer-window buffer target-frame))) + (if (and window + (or (not not-this-window-p) + (not (eq window (selected-window))))) + (return (display-buffer-1 window))) + ;; Certain buffer names get special handling. + (if special-display-function + (progn + (if (member (buffer-name buffer) + special-display-buffer-names) + (return (funcall special-display-function buffer))) - ;; Certain buffer names get special handling. - (if special-display-function - (progn - (if (member (buffer-name buffer) - special-display-buffer-names) - (throw 'done (funcall special-display-function buffer))) - - (let ((tem (assoc (buffer-name buffer) - special-display-buffer-names))) - (if tem - (throw 'done (funcall special-display-function - buffer (cdr tem))))) + (let ((tem (assoc (buffer-name buffer) + special-display-buffer-names))) + (if tem + (return (funcall special-display-function + buffer (cdr tem))))) - (let ((tem special-display-regexps)) - (while tem - (let ((car (car tem))) - (if (and (stringp car) - (string-match car (buffer-name buffer))) - (throw 'done - (funcall special-display-function buffer))) - (if (and (consp car) - (stringp (car car)) - (string-match (car car) - (buffer-name buffer))) - (throw 'done (funcall - special-display-function buffer - (cdr car))))) - (setq tem (cdr tem)))))) + (let ((tem special-display-regexps)) + (while tem + (let ((car (car tem))) + (if (and (stringp car) + (string-match car (buffer-name buffer))) + (return + (funcall special-display-function buffer))) + (if (and (consp car) + (stringp (car car)) + (string-match (car car) + (buffer-name buffer))) + (return (funcall special-display-function buffer + (cdr car))))) + (setq tem (cdr tem)))))) - ;; If there are no frames open that have more than a minibuffer, - ;; we need to create a new frame. - (if (or pop-up-frames - (null (last-nonminibuf-frame))) - (progn - (setq window (frame-selected-window - (funcall pop-up-frame-function))) - (set-window-buffer window buffer) - (throw 'done (display-buffer-1 window)))) + ;; If there are no frames open that have more than a minibuffer, + ;; we need to create a new frame. + (if (or pop-up-frames + (null (last-nonminibuf-frame))) + (progn + (setq window (frame-selected-window + (funcall pop-up-frame-function))) + (set-window-buffer window buffer) + (return (display-buffer-1 window)))) - ;; Otherwise, make it be in some window, splitting if - ;; appropriate/possible. Do not split a window if we are - ;; displaying the buffer in a different frame than that which - ;; was current when we were called. (It is already in a - ;; different window by virtue of being in another frame.) - (if (or (and pop-up-windows (eq target-frame old-frame)) - (eq 'only (frame-property (selected-frame) 'minibuffer)) - ;; If the current frame is a special display frame, - ;; don't try to reuse its windows. - (window-dedicated-p (frame-root-window (selected-frame)))) - (progn - (if (eq 'only (frame-property (selected-frame) 'minibuffer)) - (setq target-frame (last-nonminibuf-frame))) + ;; Otherwise, make it be in some window, splitting if + ;; appropriate/possible. Do not split a window if we + ;; are displaying the buffer in a different frame than + ;; that which was current when we were called. (It is + ;; already in a different window by virtue of being in + ;; another frame.) + (if (or (and pop-up-windows (eq target-frame old-frame)) + (eq 'only (frame-property (selected-frame) 'minibuffer)) + ;; If the current frame is a special display frame, + ;; don't try to reuse its windows. + (window-dedicated-p + (frame-root-window (selected-frame)))) + (progn + (if (eq 'only (frame-property (selected-frame) + 'minibuffer)) + (setq target-frame (last-nonminibuf-frame))) - ;; Don't try to create a window if would get an error with - ;; height. - (if (< split-height-threshold (* 2 window-min-height)) - (setq split-height-threshold (* 2 window-min-height))) + ;; Don't try to create a window if would get an error with + ;; height. + (if (< split-height-threshold (* 2 window-min-height)) + (setq split-height-threshold (* 2 window-min-height))) - ;; Same with width. - (if (< split-width-threshold (* 2 window-min-width)) - (setq split-width-threshold (* 2 window-min-width))) + ;; Same with width. + (if (< split-width-threshold (* 2 window-min-width)) + (setq split-width-threshold (* 2 window-min-width))) - ;; If the frame we would try to split cannot be split, - ;; try other frames. - (if (frame-property (if (null target-frame) - (selected-frame) - (last-nonminibuf-frame)) - 'unsplittable) - (setq window - ;; Try visible frames first. - (or (get-largest-window 'visible) - ;; If that didn't work, try iconified frames. - (get-largest-window 0) - (get-largest-window t))) - (setq window (get-largest-window target-frame))) + ;; If the frame we would try to split cannot be split, + ;; try other frames. + (if (frame-property (if (null target-frame) + (selected-frame) + (last-nonminibuf-frame)) + 'unsplittable) + (setq window + ;; Try visible frames first. + (or (get-largest-window 'visible) + ;; If that didn't work, try iconified frames. + (get-largest-window 0) + (get-largest-window t))) + (setq window (get-largest-window target-frame))) - ;; If we got a tall enough full-width window that - ;; can be split, split it. - (if (and window - (not (frame-property (window-frame window) - 'unsplittable)) - (>= (window-height window) split-height-threshold) - (or (>= (window-width window) - split-width-threshold) - (and (window-leftmost-p window) - (window-rightmost-p window)))) - (setq window (split-window window)) - (let (upper other) - (setq window (get-lru-window target-frame)) - ;; If the LRU window is selected, and big enough, - ;; and can be split, split it. - (if (and window - (not (frame-property (window-frame window) - 'unsplittable)) - (or (eq window (selected-window)) - (not (window-parent window))) - (>= (window-height window) - (* 2 window-min-height))) - (setq window (split-window window))) - ;; If get-lru-window returned nil, try other approaches. - ;; Try visible frames first. - (or window - (setq window (or (get-largest-window 'visible) - ;; If that didn't work, try - ;; iconified frames. - (get-largest-window 0) - ;; Try invisible frames. - (get-largest-window t) - ;; As a last resort, make - ;; a new frame. - (frame-selected-window - (funcall - pop-up-frame-function))))) - ;; If window appears above or below another, - ;; even out their heights. - (if (window-previous-child window) - (setq other (window-previous-child window) - upper other)) - (if (window-next-child window) - (setq other (window-next-child window) - upper window)) - ;; Check that OTHER and WINDOW are vertically arrayed. - (if (and other - (not (= (nth 1 (window-pixel-edges other)) - (nth 1 (window-pixel-edges window)))) - (> (window-pixel-height other) - (window-pixel-height window))) - (enlarge-window (- (/ (+ (window-height other) - (window-height window)) - 2) - (window-height upper)) - nil upper)) - ;; Klaus Berndl <klaus.berndl@sdm.de>: Only in - ;; this situation we shrink-to-fit but we can do - ;; this first after we have displayed buffer in - ;; window (s.b. (set-window-buffer window buffer)) - (setq shrink-it shrink-to-fit)))) + ;; If we got a tall enough full-width window that + ;; can be split, split it. + (if (and window + (not (frame-property (window-frame window) + 'unsplittable)) + (>= (window-height window) split-height-threshold) + (or (>= (window-width window) + split-width-threshold) + (and (window-leftmost-p window) + (window-rightmost-p window)))) + (setq window (split-window window)) + (let (upper other) + (setq window (get-lru-window target-frame)) + ;; If the LRU window is selected, and big enough, + ;; and can be split, split it. + (if (and window + (not (frame-property (window-frame window) + 'unsplittable)) + (or (eq window (selected-window)) + (not (window-parent window))) + (>= (window-height window) + (* 2 window-min-height))) + (setq window (split-window window))) + ;; If get-lru-window returned nil, try other + ;; approaches. Try visible frames first. + (or window + (setq window (or (get-largest-window 'visible) + ;; If that didn't work, try + ;; iconified frames. + (get-largest-window 0) + ;; Try invisible frames. + (get-largest-window t) + ;; As a last resort, make + ;; a new frame. + (frame-selected-window + (funcall + pop-up-frame-function))))) + ;; If window appears above or below another, + ;; even out their heights. + (if (window-previous-child window) + (setq other (window-previous-child window) + upper other)) + (if (window-next-child window) + (setq other (window-next-child window) + upper window)) + ;; Check that OTHER and WINDOW are vertically arrayed. + (if (and other + (not (= (nth 1 (window-pixel-edges other)) + (nth 1 (window-pixel-edges window)))) + (> (window-pixel-height other) + (window-pixel-height window))) + (enlarge-window (- (/ (+ (window-height other) + (window-height window)) + 2) + (window-height upper)) + nil upper)) + ;; Klaus Berndl <klaus.berndl@sdm.de>: Only in + ;; this situation we shrink-to-fit but we can do + ;; this first after we have displayed buffer in + ;; window (s.b. (set-window-buffer window buffer)) + (setq shrink-it shrink-to-fit)))) - (setq window (get-lru-window target-frame))) + (setq window (get-lru-window target-frame))) - ;; Bring the window's previous buffer to the top of the MRU chain. - (if (window-buffer window) - (save-excursion - (save-selected-window - (select-window window) - (record-buffer (window-buffer window))))) - - (set-window-buffer window buffer) + ;; Bring the window's previous buffer to the top of the + ;; MRU chain. + (if (window-buffer window) + (save-excursion + (save-selected-window + (select-window window) + (record-buffer (window-buffer window))))) - ;; Now window's previous buffer has been brought to the top - ;; of the MRU chain and window displays buffer - now we can - ;; shrink-to-fit if necessary - (if shrink-it - (shrink-window-if-larger-than-buffer window)) + (set-window-buffer window buffer) - (display-buffer-1 window))))) - (or (equal wconfig (current-window-configuration)) - (push-window-configuration wconfig)) - result)) + ;; Now window's previous buffer has been brought to the + ;; top of the MRU chain and window displays buffer - + ;; now we can shrink-to-fit if necessary + (if shrink-it + (shrink-window-if-larger-than-buffer window)) + (display-buffer-1 window)))) ;; End of prog1's 1th form. + (or (equal wconfig (current-window-configuration)) + (push-window-configuration wconfig))))) ;;; window-xemacs.el ends here
--- a/lisp/window.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/window.el Fri Aug 03 02:05:08 2012 +0900 @@ -580,7 +580,7 @@ ;; Get rid of the frame, if it has just one dedicated window ;; and other visible frames exist. (and (or (window-minibuffer-p) (window-dedicated-p window)) - (delq frame (visible-frame-list)) + (delete* frame (visible-frame-list)) window-solitary (if (and (eq default-minibuffer-frame frame) (eql 1 (length (minibuffer-frame-list))))
--- a/lisp/x-font-menu.el Fri Aug 03 02:00:29 2012 +0900 +++ b/lisp/x-font-menu.el Fri Aug 03 02:05:08 2012 +0900 @@ -233,7 +233,7 @@ done) (setq sizes (cons (car common) sizes))) (setq common (cdr common))) - (setq sizes (delq 0 sizes)))) + (setq sizes (delete* 0 sizes)))) (setq families (sort families 'string-lessp) weights (sort weights 'string-lessp)
--- a/man/ChangeLog Fri Aug 03 02:00:29 2012 +0900 +++ b/man/ChangeLog Fri Aug 03 02:05:08 2012 +0900 @@ -1,3 +1,17 @@ +2012-05-06 Aidan Kehoe <kehoea@parhasard.net> + + * lispref/macros.texi (Expansion): + Cross-reference to documentation of #'cl-prettyexpand, #'defmacro* + when talking about #'macroexpand. + +2012-05-04 Aidan Kehoe <kehoea@parhasard.net> + + * lispref/searching.texi (Regular Expressions): + * lispref/searching.texi (Syntax of Regexps): + * lispref/searching.texi (Char Classes): + * lispref/searching.texi (Regexp Example): + Document the predefined character classes in this file. + 2011-12-30 Aidan Kehoe <kehoea@parhasard.net> * cl.texi (Top):
--- a/man/lispref/macros.texi Fri Aug 03 02:00:29 2012 +0900 +++ b/man/lispref/macros.texi Fri Aug 03 02:05:08 2012 +0900 @@ -88,7 +88,9 @@ this is unusual. You can see the expansion of a given macro call by calling -@code{macroexpand}. +@code{macroexpand}. However, in normal use, @code{cl-prettyexpand} will be +more helpful, since it expands @emph{all} the macros in the form, and prints +the output with more readable indentation. @pxref{(cl)Efficiency Concerns}. @defun macroexpand form &optional environment @cindex macro expansion @@ -106,9 +108,16 @@ Normally there is no need for that, since a call to an inline function is no harder to understand than a call to an ordinary function. -If @var{environment} is provided, it specifies an alist of macro -definitions that shadow the currently defined macros. Byte compilation -uses this feature. +If @var{environment} is provided, it specifies an alist of macro definitions +that shadow the currently defined macros. Byte compilation uses this feature. + +To access @var{environment} within the body of a macro, define the macro using +@code{defmacro*} or @code{macrolet}, and use the @code{&environment} lambda +list keyword. This may be necessary if you need to force macro expansion of +the body of a form at the same time as top-level macro expansion. +@pxref{(cl)Argument Lists}. + +Macro expansion examples: @smallexample @group
--- a/man/lispref/searching.texi Fri Aug 03 02:00:29 2012 +0900 +++ b/man/lispref/searching.texi Fri Aug 03 02:05:08 2012 +0900 @@ -180,6 +180,7 @@ @menu * Syntax of Regexps:: Rules for writing regular expressions. +* Char Classes:: Predefined character classes for searching. * Regexp Example:: Illustrates regular expression syntax. @end menu @@ -335,6 +336,11 @@ To include @samp{^} in a set, put it anywhere but at the beginning of the set. +It is also possible to specify named character classes as part of your +character set; for example, @samp{[:xdigit:]} will match hexadecimal +digits, @samp{[:nonascii:]} will match characters outside the basic +ASCII set. These are documented elsewhere, @pxref{Char Classes}. + @item [^ @dots{} ] @cindex @samp{^} in regexp @samp{[^} begins a @dfn{complement character set}, which matches any @@ -604,6 +610,61 @@ @end example @end defun +@node Char Classes +@subsection Char Classes + +These are the predefined character classes available within regular +expression character sets, and within @samp{skip-chars-forward} and +@samp{skip-chars-backward}, @xref{Skipping Characters}. + +@table @samp +@item [:alnum:] +This matches any ASCII letter or digit, or any non-ASCII character +with word syntax. +@item [:alpha:] +This matches any ASCII letter, or any non-ASCII character with word syntax. +@item [:ascii:] +This matches any character with a numeric value below @samp{?\x80}. +@item [:blank:] +This matches space or tab. +@item [:cntrl:] +This matches any character with a numeric value below @samp{?\x20}, +the code for space; these are the ASCII control characters. +@item [:digit:] +This matches the characters @samp{?0} to @samp{?9}, inclusive. +@item [:graph:] +This matches ``graphic'' characters, with numeric values greater than +@samp{?\x20}, exclusive of @samp{?\x7f}, the delete character. +@item [:lower:] +This matches minuscule characters, or any character with case +information if @samp{case-fold-search} is non-nil. +@item [:multibyte:] +This matches non-ASCII characters, that is, any character with a +numeric value above @samp{?\x7f}. +@item [:nonascii:] +This is equivalent to @samp{[:multibyte:]}. +@item [:print:] +This is equivalent to [:graph:], but also matches the space character, +@samp{?\x20}. +@item [:punct:] +This matches non-control, non-alphanumeric ASCII characters, or any +non-ASCII character without word syntax. +@item [:space:] +This matches any character with whitespace syntax. +@item [:unibyte:] +This is a GNU Emacs extension; in XEmacs it is equivalent to +@samp{[:ascii:]}. Note that this means it is not equivalent to +@samp{"\x00-\xff"}, which one might have assumed to be the case. +@item [:upper:] +This matches majuscule characters, or any character with case +information if @samp{case-fold-search} is non-nil. +@item [:word:] +This matches any character with word syntax. +@item [:xdigit:] +This matches hexadecimal digits, so the decimal digits @samp{0-9} and the +letters @samp{a-F} and @samp{A-F}. +@end table + @node Regexp Example @subsection Complex Regexp Example
--- a/src/ChangeLog Fri Aug 03 02:00:29 2012 +0900 +++ b/src/ChangeLog Fri Aug 03 02:05:08 2012 +0900 @@ -1,3 +1,90 @@ +2012-05-14 Aidan Kehoe <kehoea@parhasard.net> + + * minibuf.c (Ftest_completion): + Correct some documentation here. + +2012-05-07 Jeff Sparkes <jsparkes@gmail.com> + + * search.c (skip_chars): Add cast to Ibyte *. + +2012-05-06 Aidan Kehoe <kehoea@parhasard.net> + + * eval.c: + * eval.c (Fmacroexpand): + Don't prepend any supplied environment to + Vbyte_compile_macro_environment, leave that up to our callers + (that's what the &environment argument is for). + Document that one should normally access + byte-compile-macro-environment using the &environment lambda list + keyword. + +2012-05-04 Aidan Kehoe <kehoea@parhasard.net> + + * regex.c: + Move various #defines and enums to regex.h, since we need them + when implementing #'skip-chars-{backward,forward}. + * regex.c (re_wctype): + * regex.c (re_iswctype): + Be more robust about case insensitivity here. + * regex.c (regex_compile): + * regex.h: + * regex.h (RE_ISWCTYPE_ARG_DECL): + * regex.h (CHAR_CLASS_MAX_LENGTH): + * search.c (skip_chars): + Implement support for the predefined character classes in this + function. + +2012-04-25 Aidan Kehoe <kehoea@parhasard.net> + + * search.c (string_match_1): Actually use the POSIX argument here, + pass it to compile_pattern(). Thank you for the bug report, Ilya + Shlyakhter! + +2012-04-21 Aidan Kehoe <kehoea@parhasard.net> + + Support non-ASCII correctly in character classes ([:alnum:] and + friends). + + * regex.c: + * regex.c (ISBLANK, ISUNIBYTE): New. Make these and friends + independent of the locale, since we want them to be consistent in + XEmacs. + * regex.c (print_partial_compiled_pattern): Print the flags for + charset_mule; don't print non-ASCII as the character values in + ranges, this breaks with locales. + * regex.c (enum): + Define various flags the charset_mule and charset_mule_not opcodes + can now take. + * regex.c (CHAR_CLASS_MAX_LENGTH): Update this. + * regex.c (re_iswctype, re_wctype): New, from GNU. + * regex.c (re_wctype_can_match_non_ascii): New; used when deciding + on whether to use charset_mule or the ASCII-only regex character + set opcode. + * regex.c (regex_compile): + Error correctly on long, non-existent character class names. + Break out the handling of charsets that can match non-ASCII into a + separate clause. Use compile_char_class when compiling character + classes. + * regex.c (compile_char_class): New. Used in regex_compile when + compiling character sets that may match non-ASCII. + * regex.c (re_compile_fastmap): + If there are flags set for charset_mule or charset_mule_not, we + can't use the fastmap (since we need to check syntax table values + that aren't available there). + * regex.c (re_match_2_internal): + Check the new flags passed to the charset_mule{,_not} opcode, + observe them if appropriate. + * regex.h: + * regex.h (enum): + Expose re_wctype_t here, imported from GNU. + +2012-04-21 Aidan Kehoe <kehoea@parhasard.net> + + * regex.h (RE_SYNTAX_EMACS): + Turn on character classes ([:alnum:] and friends) by default. This + implementation is incomplete, am working on a version that handles + non-ASCII characters correctly. + 2012-02-12 Vin Shelton <acs@xemacs.org> * sysproc.h: As of Cygwin 1.7.10, /usr/include/process.h has moved @@ -5,6 +92,11 @@ find it. It wasn't needed anyway, so remove the include under cygwin. +2012-04-14 Aidan Kehoe <kehoea@parhasard.net> + + * number-mp.c (bignum_ceil): Remove a redundant double division + from this function. + 2012-01-08 Aidan Kehoe <kehoea@parhasard.net> * device-x.c:
--- a/src/eval.c Fri Aug 03 02:00:29 2012 +0900 +++ b/src/eval.c Fri Aug 03 02:05:08 2012 +0900 @@ -1565,22 +1565,10 @@ REGISTER Lisp_Object expander, sym, def, tem; int speccount = specpdl_depth (); - if (!NILP (environment) && - !EQ (environment, Vbyte_compile_macro_environment)) - { - if (NILP (Vbyte_compile_macro_environment)) - { - specbind (Qbyte_compile_macro_environment, environment); - } - else - { - specbind (Qbyte_compile_macro_environment, - nconc2 (Fcopy_list (environment), - Vbyte_compile_macro_environment)); - } - } - - environment = Vbyte_compile_macro_environment; + if (!EQ (environment, Vbyte_compile_macro_environment)) + { + specbind (Qbyte_compile_macro_environment, environment); + } while (1) { @@ -7661,6 +7649,10 @@ Alist of macros defined in the file being compiled. Each element looks like (MACRONAME . DEFINITION). It is \(MACRONAME . nil) when a macro is redefined as a function. + +You should normally access this using the &environment argument to +#'macrolet, #'defmacro* and friends, and not directly; see the documentation +of those macros. */); Vbyte_compile_macro_environment = Qnil;
--- a/src/minibuf.c Fri Aug 03 02:00:29 2012 +0900 +++ b/src/minibuf.c Fri Aug 03 02:05:08 2012 +0900 @@ -688,13 +688,12 @@ } DEFUN ("test-completion", Ftest_completion, 2, 3, 0, /* -Return non-nil if STRING is a valid completion in COLLECTION. +Return non-nil if STRING is an exact completion in COLLECTION. COLLECTION must be a list, a hash table, an obarray, or a function. Each string (or symbol) in COLLECTION is tested to see if it (or its -name) begins with STRING. The value is a list of all the strings from -COLLECTION that match. +name) begins with STRING, until a valid, exact completion is found. If COLLECTION is a list, the elements of the list that are not cons cells and the cars of the elements of the list that are cons cells @@ -755,7 +754,7 @@ lookup, 0) ? Qnil : Qt; /* It would be reasonable to do something similar for the hash - tables, except, both symbol and string keys are vaild + tables, except, both symbol and string keys are valid completions there. So a negative #'gethash for the string (with #'equal as the hash table tests) still means you have to do the linear search, for any symbols with that string
--- a/src/number-mp.c Fri Aug 03 02:00:29 2012 +0900 +++ b/src/number-mp.c Fri Aug 03 02:05:08 2012 +0900 @@ -322,7 +322,7 @@ void bignum_ceil (bignum quotient, bignum N, bignum D) { MP_MDIV (N, D, quotient, intern_bignum); - MP_MDIV (N, D, quotient, intern_bignum); + if (MP_MCMP (intern_bignum, bignum_zero) != 0) { short signN = MP_MCMP (N, bignum_zero);
--- a/src/regex.c Fri Aug 03 02:00:29 2012 +0900 +++ b/src/regex.c Fri Aug 03 02:05:08 2012 +0900 @@ -178,53 +178,47 @@ /* isalpha etc. are used for the character classes. */ #include <ctype.h> -/* Jim Meyering writes: - - "... Some ctype macros are valid only for character codes that - isascii says are ASCII (SGI's IRIX-4.0.5 is one such system --when - using /bin/cc or gcc but without giving an ansi option). So, all - ctype uses should be through macros like ISPRINT... If - STDC_HEADERS is defined, then autoconf has verified that the ctype - macros don't need to be guarded with references to isascii. ... - Defining isascii to 1 should let any compiler worth its salt - eliminate the && through constant folding." */ - -#if defined (STDC_HEADERS) || (!defined (isascii) && !defined (HAVE_ISASCII)) -#define ISASCII_1(c) 1 -#else -#define ISASCII_1(c) isascii(c) -#endif - -#ifdef MULE -/* The IS*() macros can be passed any character, including an extended - one. We need to make sure there are no crashes, which would occur - otherwise due to out-of-bounds array references. */ -#define ISASCII(c) (((EMACS_UINT) (c)) < 0x100 && ISASCII_1 (c)) -#else -#define ISASCII(c) ISASCII_1 (c) -#endif /* MULE */ +#ifndef emacs /* For the emacs build, we need these in the header. */ + +/* 1 if C is an ASCII character. */ +#define ISASCII(c) ((c) < 0200) + +/* 1 if C is a unibyte character. */ +#define ISUNIBYTE(c) 0 #ifdef isblank -#define ISBLANK(c) (ISASCII (c) && isblank (c)) +# define ISBLANK(c) isblank (c) #else -#define ISBLANK(c) ((c) == ' ' || (c) == '\t') +# define ISBLANK(c) ((c) == ' ' || (c) == '\t') #endif #ifdef isgraph -#define ISGRAPH(c) (ISASCII (c) && isgraph (c)) +# define ISGRAPH(c) isgraph (c) #else -#define ISGRAPH(c) (ISASCII (c) && isprint (c) && !isspace (c)) +# define ISGRAPH(c) (isprint (c) && !isspace (c)) #endif -#define ISPRINT(c) (ISASCII (c) && isprint (c)) -#define ISDIGIT(c) (ISASCII (c) && isdigit (c)) -#define ISALNUM(c) (ISASCII (c) && isalnum (c)) -#define ISALPHA(c) (ISASCII (c) && isalpha (c)) -#define ISCNTRL(c) (ISASCII (c) && iscntrl (c)) -#define ISLOWER(c) (ISASCII (c) && islower (c)) -#define ISPUNCT(c) (ISASCII (c) && ispunct (c)) -#define ISSPACE(c) (ISASCII (c) && isspace (c)) -#define ISUPPER(c) (ISASCII (c) && isupper (c)) -#define ISXDIGIT(c) (ISASCII (c) && isxdigit (c)) +/* Solaris defines ISPRINT so we must undefine it first. */ +#undef ISPRINT +#define ISPRINT(c) isprint (c) +#define ISDIGIT(c) isdigit (c) +#define ISALNUM(c) isalnum (c) +#define ISALPHA(c) isalpha (c) +#define ISCNTRL(c) iscntrl (c) +#define ISLOWER(c) islower (c) +#define ISPUNCT(c) ispunct (c) +#define ISSPACE(c) isspace (c) +#define ISUPPER(c) isupper (c) +#define ISXDIGIT(c) isxdigit (c) + +#define ISWORD(c) ISALPHA (c) + +#ifdef _tolower +# define TOLOWER(c) _tolower (c) +#else +# define TOLOWER(c) tolower (c) +#endif + +#endif /* emacs */ #ifndef NULL #define NULL (void *)0 @@ -913,6 +907,7 @@ printf ("/charset_mule [%s", (re_opcode_t) *(p - 1) == charset_mule_not ? "^" : ""); + printf (" flags: 0x%02x ", *p++); nentries = unified_range_table_nentries (p); for (i = 0; i < nentries; i++) { @@ -921,14 +916,14 @@ unified_range_table_get_range (p, i, &first, &last, &dummy_val); - if (first < 0x100) + if (first < 0x80) putchar (first); else printf ("(0x%lx)", (long)first); if (first != last) { putchar ('-'); - if (last < 0x100) + if (last < 0x80) putchar (last); else printf ("(0x%lx)", (long)last); @@ -1974,7 +1969,6 @@ /* The next available element. */ #define COMPILE_STACK_TOP (compile_stack.stack[compile_stack.avail]) - /* Set the bit for character C in a bit vector. */ #define SET_LIST_BIT(c) \ (buf_end[((unsigned char) (c)) / BYTEWIDTH] \ @@ -1985,22 +1979,8 @@ /* Set the "bit" for character C in a range table. */ #define SET_RANGETAB_BIT(c) put_range_table (rtab, c, c, Qt) -/* Set the "bit" for character c in the appropriate table. */ -#define SET_EITHER_BIT(c) \ - do { \ - if (has_extended_chars) \ - SET_RANGETAB_BIT (c); \ - else \ - SET_LIST_BIT (c); \ - } while (0) - -#else /* not MULE */ - -#define SET_EITHER_BIT(c) SET_LIST_BIT (c) - #endif - /* Get the next unsigned number in the uncompiled pattern. */ #define GET_UNSIGNED_NUMBER(num) \ { if (p != pend) \ @@ -2018,15 +1998,115 @@ } \ } -#define CHAR_CLASS_MAX_LENGTH 6 /* Namely, `xdigit'. */ - -#define IS_CHAR_CLASS(string) \ - (STREQ (string, "alpha") || STREQ (string, "upper") \ - || STREQ (string, "lower") || STREQ (string, "digit") \ - || STREQ (string, "alnum") || STREQ (string, "xdigit") \ - || STREQ (string, "space") || STREQ (string, "print") \ - || STREQ (string, "punct") || STREQ (string, "graph") \ - || STREQ (string, "cntrl") || STREQ (string, "blank")) +/* Map a string to the char class it names (if any). */ +re_wctype_t +re_wctype (const char *string) +{ + if (STREQ (string, "alnum")) return RECC_ALNUM; + else if (STREQ (string, "alpha")) return RECC_ALPHA; + else if (STREQ (string, "word")) return RECC_WORD; + else if (STREQ (string, "ascii")) return RECC_ASCII; + else if (STREQ (string, "nonascii")) return RECC_NONASCII; + else if (STREQ (string, "graph")) return RECC_GRAPH; + else if (STREQ (string, "lower")) return RECC_LOWER; + else if (STREQ (string, "print")) return RECC_PRINT; + else if (STREQ (string, "punct")) return RECC_PUNCT; + else if (STREQ (string, "space")) return RECC_SPACE; + else if (STREQ (string, "upper")) return RECC_UPPER; + else if (STREQ (string, "unibyte")) return RECC_UNIBYTE; + else if (STREQ (string, "multibyte")) return RECC_MULTIBYTE; + else if (STREQ (string, "digit")) return RECC_DIGIT; + else if (STREQ (string, "xdigit")) return RECC_XDIGIT; + else if (STREQ (string, "cntrl")) return RECC_CNTRL; + else if (STREQ (string, "blank")) return RECC_BLANK; + else return RECC_ERROR; +} + +/* True if CH is in the char class CC. */ +int +re_iswctype (int ch, re_wctype_t cc + RE_ISWCTYPE_ARG_DECL) +{ + switch (cc) + { + case RECC_ALNUM: return ISALNUM (ch) != 0; + case RECC_ALPHA: return ISALPHA (ch) != 0; + case RECC_BLANK: return ISBLANK (ch) != 0; + case RECC_CNTRL: return ISCNTRL (ch) != 0; + case RECC_DIGIT: return ISDIGIT (ch) != 0; + case RECC_GRAPH: return ISGRAPH (ch) != 0; + case RECC_PRINT: return ISPRINT (ch) != 0; + case RECC_PUNCT: return ISPUNCT (ch) != 0; + case RECC_SPACE: return ISSPACE (ch) != 0; +#ifdef emacs + case RECC_UPPER: + return NILP (lispbuf->case_fold_search) ? ISUPPER (ch) != 0 + : !NOCASEP (lispbuf, ch); + case RECC_LOWER: + return NILP (lispbuf->case_fold_search) ? ISLOWER (ch) != 0 + : !NOCASEP (lispbuf, ch); +#else + case RECC_UPPER: return ISUPPER (ch) != 0; + case RECC_LOWER: return ISLOWER (ch) != 0; +#endif + case RECC_XDIGIT: return ISXDIGIT (ch) != 0; + case RECC_ASCII: return ISASCII (ch) != 0; + case RECC_NONASCII: case RECC_MULTIBYTE: return !ISASCII (ch); + case RECC_UNIBYTE: return ISUNIBYTE (ch) != 0; + case RECC_WORD: return ISWORD (ch) != 0; + case RECC_ERROR: return false; + default: + abort (); + } +} + +#ifdef MULE + +static re_bool +re_wctype_can_match_non_ascii (re_wctype_t cc) +{ + switch (cc) + { + case RECC_ASCII: + case RECC_UNIBYTE: + case RECC_CNTRL: + case RECC_DIGIT: + case RECC_XDIGIT: + case RECC_BLANK: + return false; + default: + return true; + } +} + +#endif /* MULE */ + +#ifdef emacs + +/* Return a bit-pattern to use in the range-table bits to match multibyte + chars of class CC. */ +static unsigned char +re_wctype_to_bit (re_wctype_t cc) +{ + switch (cc) + { + case RECC_PRINT: case RECC_GRAPH: + case RECC_ALPHA: return BIT_ALPHA; + case RECC_ALNUM: case RECC_WORD: return BIT_WORD; + case RECC_LOWER: return BIT_LOWER; + case RECC_UPPER: return BIT_UPPER; + case RECC_PUNCT: return BIT_PUNCT; + case RECC_SPACE: return BIT_SPACE; + case RECC_MULTIBYTE: case RECC_NONASCII: + case RECC_ASCII: case RECC_DIGIT: case RECC_XDIGIT: case RECC_CNTRL: + case RECC_BLANK: case RECC_UNIBYTE: case RECC_ERROR: return 0; + default: + ABORT (); + return 0; + } +} + +#endif /* emacs */ static void store_op1 (re_opcode_t op, unsigned char *loc, int arg); static void store_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2); @@ -2050,6 +2130,11 @@ reg_syntax_t syntax, Lisp_Object rtab); #endif /* MULE */ +#ifdef emacs +reg_errcode_t compile_char_class (re_wctype_t cc, Lisp_Object rtab, + Bitbyte *flags_out); +#endif + static re_bool group_match_null_string_p (unsigned char **p, unsigned char *end, register_info_type *reg_info); @@ -2512,15 +2597,20 @@ BUF_PUSH (anychar); break; +#ifdef MULE +#define MAYBE_START_OVER_WITH_EXTENDED(ch) \ + if (ch >= 0x80) \ + { \ + goto start_over_with_extended; \ + } while (0) +#else +#define MAYBE_START_OVER_WITH_EXTENDED(ch) +#endif case '[': { /* XEmacs change: this whole section */ re_bool had_char_class = false; -#ifdef MULE - re_bool has_extended_chars = false; - REGISTER Lisp_Object rtab = Qnil; -#endif if (p == pend) FREE_STACK_RETURN (REG_EBRACK); @@ -2550,29 +2640,6 @@ && (syntax & RE_HAT_LISTS_NOT_NEWLINE)) SET_LIST_BIT ('\n'); -#ifdef MULE - start_over_with_extended: - if (has_extended_chars) - { - /* There are extended chars here, which means we need to start - over and shift to unified range-table format. */ - if (buf_end[-2] == charset) - buf_end[-2] = charset_mule; - else - buf_end[-2] = charset_mule_not; - buf_end--; - p = p1; /* go back to the beginning of the charset, after - a possible ^. */ - rtab = Vthe_lisp_rangetab; - Fclear_range_table (rtab); - - /* charset_not matches newline according to a syntax bit. */ - if ((re_opcode_t) buf_end[-1] == charset_mule_not - && (syntax & RE_HAT_LISTS_NOT_NEWLINE)) - SET_EITHER_BIT ('\n'); - } -#endif /* MULE */ - /* Read in characters and ranges, setting map bits. */ for (;;) { @@ -2580,32 +2647,22 @@ PATFETCH (c); -#ifdef MULE - if (c >= 0x80 && !has_extended_chars) - { - has_extended_chars = 1; - /* Frumble-bumble, we've found some extended chars. - Need to start over, process everything using - the general extended-char mechanism, and need - to use charset_mule and charset_mule_not instead - of charset and charset_not. */ - goto start_over_with_extended; - } -#endif /* MULE */ + /* Frumble-bumble, we may have found some extended chars. + Need to start over, process everything using the general + extended-char mechanism, and need to use charset_mule and + charset_mule_not instead of charset and charset_not. */ + MAYBE_START_OVER_WITH_EXTENDED (c); + /* \ might escape characters inside [...] and [^...]. */ if ((syntax & RE_BACKSLASH_ESCAPE_IN_LISTS) && c == '\\') { if (p == pend) FREE_STACK_RETURN (REG_EESCAPE); PATFETCH (c1); -#ifdef MULE - if (c1 >= 0x80 && !has_extended_chars) - { - has_extended_chars = 1; - goto start_over_with_extended; - } -#endif /* MULE */ - SET_EITHER_BIT (c1); + + MAYBE_START_OVER_WITH_EXTENDED (c1); + + SET_LIST_BIT (c1); continue; } @@ -2631,18 +2688,11 @@ { reg_errcode_t ret; -#ifdef MULE - if (* (unsigned char *) p >= 0x80 && !has_extended_chars) - { - has_extended_chars = 1; - goto start_over_with_extended; - } - if (has_extended_chars) - ret = compile_extended_range (&p, pend, translate, - syntax, rtab); - else -#endif /* MULE */ - ret = compile_range (&p, pend, translate, syntax, buf_end); + MAYBE_START_OVER_WITH_EXTENDED (*(unsigned char *)p); + + ret = compile_range (&p, pend, translate, syntax, + buf_end); + if (ret != REG_NOERROR) FREE_STACK_RETURN (ret); } @@ -2653,18 +2703,178 @@ /* Move past the `-'. */ PATFETCH (c1); + MAYBE_START_OVER_WITH_EXTENDED (*(unsigned char *)p); + + ret = compile_range (&p, pend, translate, syntax, buf_end); + + if (ret != REG_NOERROR) FREE_STACK_RETURN (ret); + } + + /* See if we're at the beginning of a possible character + class. */ + + else if (syntax & RE_CHAR_CLASSES && c == '[' && *p == ':') + { /* Leave room for the null. */ + char str[CHAR_CLASS_MAX_LENGTH + 1]; + int ch = 0; + + PATFETCH (c); + c1 = 0; + + /* If pattern is `[[:'. */ + if (p == pend) FREE_STACK_RETURN (REG_EBRACK); + + for (;;) + { + PATFETCH (c); + if ((c == ':' && *p == ']') || p == pend) + break; + if (c1 < CHAR_CLASS_MAX_LENGTH) + str[c1++] = c; + else + /* This is in any case an invalid class name. */ + str[0] = '\0'; + } + str[c1] = '\0'; + + /* If isn't a word bracketed by `[:' and `:]': + undo the ending character, the letters, and leave + the leading `:' and `[' (but set bits for them). */ + if (c == ':' && *p == ']') + { + re_wctype_t cc = re_wctype (str); + + if (cc == RECC_ERROR) + FREE_STACK_RETURN (REG_ECTYPE); + + /* Throw away the ] at the end of the character + class. */ + PATFETCH (c); + + if (p == pend) FREE_STACK_RETURN (REG_EBRACK); + #ifdef MULE - if (* (unsigned char *) p >= 0x80 && !has_extended_chars) - { - has_extended_chars = 1; - goto start_over_with_extended; + if (re_wctype_can_match_non_ascii (cc)) + { + goto start_over_with_extended; + } +#endif /* MULE */ + for (ch = 0; ch < (1 << BYTEWIDTH); ++ch) + { + if (re_iswctype (ch, cc + RE_ISWCTYPE_ARG (current_buffer))) + { + SET_LIST_BIT (ch); + } + } + + had_char_class = true; + } + else + { + c1++; + while (c1--) + PATUNFETCH; + SET_LIST_BIT ('['); + SET_LIST_BIT (':'); + had_char_class = false; } - if (has_extended_chars) - ret = compile_extended_range (&p, pend, translate, - syntax, rtab); - else -#endif /* MULE */ - ret = compile_range (&p, pend, translate, syntax, buf_end); + } + else + { + had_char_class = false; + SET_LIST_BIT (c); + } + } + + /* Discard any (non)matching list bytes that are all 0 at the + end of the map. Decrease the map-length byte too. */ + while ((int) buf_end[-1] > 0 && buf_end[buf_end[-1] - 1] == 0) + buf_end[-1]--; + buf_end += buf_end[-1]; + } + break; + +#ifdef MULE + start_over_with_extended: + { + REGISTER Lisp_Object rtab = Qnil; + Bitbyte flags = 0; + int bytes_needed = sizeof (flags); + re_bool had_char_class = false; + + /* There are extended chars here, which means we need to use the + unified range-table format. */ + if (buf_end[-2] == charset) + buf_end[-2] = charset_mule; + else + buf_end[-2] = charset_mule_not; + buf_end--; + p = p1; /* go back to the beginning of the charset, after + a possible ^. */ + rtab = Vthe_lisp_rangetab; + Fclear_range_table (rtab); + + /* charset_not matches newline according to a syntax bit. */ + if ((re_opcode_t) buf_end[-1] == charset_mule_not + && (syntax & RE_HAT_LISTS_NOT_NEWLINE)) + SET_RANGETAB_BIT ('\n'); + + /* Read in characters and ranges, setting map bits. */ + for (;;) + { + if (p == pend) FREE_STACK_RETURN (REG_EBRACK); + + PATFETCH (c); + + /* \ might escape characters inside [...] and [^...]. */ + if ((syntax & RE_BACKSLASH_ESCAPE_IN_LISTS) && c == '\\') + { + if (p == pend) FREE_STACK_RETURN (REG_EESCAPE); + + PATFETCH (c1); + + SET_RANGETAB_BIT (c1); + continue; + } + + /* Could be the end of the bracket expression. If it's + not (i.e., when the bracket expression is `[]' so + far), the ']' character bit gets set way below. */ + if (c == ']' && p != p1 + 1) + break; + + /* Look ahead to see if it's a range when the last thing + was a character class. */ + if (had_char_class && c == '-' && *p != ']') + FREE_STACK_RETURN (REG_ERANGE); + + /* Look ahead to see if it's a range when the last thing + was a character: if this is a hyphen not at the + beginning or the end of a list, then it's the range + operator. */ + if (c == '-' + && !(p - 2 >= pattern && p[-2] == '[') + && !(p - 3 >= pattern && p[-3] == '[' && p[-2] == '^') + && *p != ']') + { + reg_errcode_t ret; + + ret = compile_extended_range (&p, pend, translate, syntax, + rtab); + + if (ret != REG_NOERROR) FREE_STACK_RETURN (ret); + } + + else if (p[0] == '-' && p[1] != ']') + { /* This handles ranges made up of characters only. */ + reg_errcode_t ret; + + /* Move past the `-'. */ + PATFETCH (c1); + + ret = compile_extended_range (&p, pend, translate, + syntax, rtab); if (ret != REG_NOERROR) FREE_STACK_RETURN (ret); } @@ -2683,14 +2893,14 @@ for (;;) { - /* #### This code is unused. - Correctness is not checked after TRT - table change. */ PATFETCH (c); - if (c == ':' || c == ']' || p == pend - || c1 == CHAR_CLASS_MAX_LENGTH) + if ((c == ':' && *p == ']') || p == pend) break; - str[c1++] = (char) c; + if (c1 < CHAR_CLASS_MAX_LENGTH) + str[c1++] = c; + else + /* This is in any case an invalid class name. */ + str[0] = '\0'; } str[c1] = '\0'; @@ -2699,22 +2909,11 @@ the leading `:' and `[' (but set bits for them). */ if (c == ':' && *p == ']') { - int ch; - re_bool is_alnum = STREQ (str, "alnum"); - re_bool is_alpha = STREQ (str, "alpha"); - re_bool is_blank = STREQ (str, "blank"); - re_bool is_cntrl = STREQ (str, "cntrl"); - re_bool is_digit = STREQ (str, "digit"); - re_bool is_graph = STREQ (str, "graph"); - re_bool is_lower = STREQ (str, "lower"); - re_bool is_print = STREQ (str, "print"); - re_bool is_punct = STREQ (str, "punct"); - re_bool is_space = STREQ (str, "space"); - re_bool is_upper = STREQ (str, "upper"); - re_bool is_xdigit = STREQ (str, "xdigit"); - - if (!IS_CHAR_CLASS (str)) - FREE_STACK_RETURN (REG_ECTYPE); + re_wctype_t cc = re_wctype (str); + reg_errcode_t ret = REG_NOERROR; + + if (cc == RECC_ERROR) + FREE_STACK_RETURN (REG_ECTYPE); /* Throw away the ] at the end of the character class. */ @@ -2722,26 +2921,10 @@ if (p == pend) FREE_STACK_RETURN (REG_EBRACK); - for (ch = 0; ch < 1 << BYTEWIDTH; ch++) - { - /* This was split into 3 if's to - avoid an arbitrary limit in some compiler. */ - if ( (is_alnum && ISALNUM (ch)) - || (is_alpha && ISALPHA (ch)) - || (is_blank && ISBLANK (ch)) - || (is_cntrl && ISCNTRL (ch))) - SET_EITHER_BIT (ch); - if ( (is_digit && ISDIGIT (ch)) - || (is_graph && ISGRAPH (ch)) - || (is_lower && ISLOWER (ch)) - || (is_print && ISPRINT (ch))) - SET_EITHER_BIT (ch); - if ( (is_punct && ISPUNCT (ch)) - || (is_space && ISSPACE (ch)) - || (is_upper && ISUPPER (ch)) - || (is_xdigit && ISXDIGIT (ch))) - SET_EITHER_BIT (ch); - } + ret = compile_char_class (cc, rtab, &flags); + + if (ret != REG_NOERROR) FREE_STACK_RETURN (ret); + had_char_class = true; } else @@ -2749,38 +2932,26 @@ c1++; while (c1--) PATUNFETCH; - SET_EITHER_BIT ('['); - SET_EITHER_BIT (':'); + SET_RANGETAB_BIT ('['); + SET_RANGETAB_BIT (':'); had_char_class = false; } } else { had_char_class = false; - SET_EITHER_BIT (c); + SET_RANGETAB_BIT (c); } } -#ifdef MULE - if (has_extended_chars) - { - /* We have a range table, not a bit vector. */ - int bytes_needed = - unified_range_table_bytes_needed (rtab); - GET_BUFFER_SPACE (bytes_needed); - unified_range_table_copy_data (rtab, buf_end); - buf_end += unified_range_table_bytes_used (buf_end); - break; - } + bytes_needed += unified_range_table_bytes_needed (rtab); + GET_BUFFER_SPACE (bytes_needed); + *buf_end++ = flags; + unified_range_table_copy_data (rtab, buf_end); + buf_end += unified_range_table_bytes_used (buf_end); + break; + } #endif /* MULE */ - /* Discard any (non)matching list bytes that are all 0 at the - end of the map. Decrease the map-length byte too. */ - while ((int) buf_end[-1] > 0 && buf_end[buf_end[-1] - 1] == 0) - buf_end[-1]--; - buf_end += buf_end[-1]; - } - break; - case '(': if (syntax & RE_NO_BK_PARENS) @@ -3716,6 +3887,73 @@ } #endif /* MULE */ + +#ifdef emacs + +reg_errcode_t +compile_char_class (re_wctype_t cc, Lisp_Object rtab, Bitbyte *flags_out) +{ + *flags_out |= re_wctype_to_bit (cc); + + switch (cc) + { + case RECC_ASCII: + put_range_table (rtab, 0, 0x7f, Qt); + break; + + case RECC_XDIGIT: + put_range_table (rtab, 'a', 'f', Qt); + put_range_table (rtab, 'A', 'f', Qt); + /* fallthrough */ + case RECC_DIGIT: + put_range_table (rtab, '0', '9', Qt); + break; + + case RECC_BLANK: + put_range_table (rtab, ' ', ' ', Qt); + put_range_table (rtab, '\t', '\t', Qt); + break; + + case RECC_PRINT: + put_range_table (rtab, ' ', 0x7e, Qt); + put_range_table (rtab, 0x80, MOST_POSITIVE_FIXNUM, Qt); + break; + + case RECC_GRAPH: + put_range_table (rtab, '!', 0x7e, Qt); + put_range_table (rtab, 0x80, MOST_POSITIVE_FIXNUM, Qt); + break; + + case RECC_NONASCII: + case RECC_MULTIBYTE: + put_range_table (rtab, 0x80, MOST_POSITIVE_FIXNUM, Qt); + break; + + case RECC_CNTRL: + put_range_table (rtab, 0x00, 0x1f, Qt); + break; + + case RECC_UNIBYTE: + /* Never true in XEmacs. */ + break; + + /* The following all have their own bits in the class_bits argument to + charset_mule and charset_mule_not, they don't use the range table + information. */ + case RECC_ALPHA: + case RECC_WORD: + case RECC_ALNUM: /* Equivalent to RECC_WORD */ + case RECC_LOWER: + case RECC_PUNCT: + case RECC_SPACE: + case RECC_UPPER: + break; + } + + return REG_NOERROR; +} + +#endif /* MULE */ /* re_compile_fastmap computes a ``fastmap'' for the compiled pattern in BUFP. A fastmap records which of the (1 << BYTEWIDTH) possible @@ -3855,6 +4093,15 @@ { int nentries; int i; + Bitbyte flags = *p++; + + if (flags) + { + /* We need to consult the syntax table, fastmap won't + work. */ + bufp->can_be_null = 1; + goto done; + } nentries = unified_range_table_nentries (p); for (i = 0; i < nentries; i++) @@ -3878,6 +4125,16 @@ set_itext_ichar (strr, last); fastmap[*strr] = 1; } + else if (MOST_POSITIVE_FIXNUM == last) + { + /* This is RECC_MULTIBYTE or RECC_NONASCII; true for all + non-ASCII characters. */ + jj = 0x80; + while (jj < 0xA0) + { + fastmap[jj++] = 1; + } + } } } break; @@ -3887,6 +4144,15 @@ int nentries; int i; int smallest_prev = 0; + Bitbyte flags = *p++; + + if (flags) + { + /* We need to consult the syntax table, fastmap won't + work. */ + bufp->can_be_null = 1; + goto done; + } nentries = unified_range_table_nentries (p); for (i = 0; i < nentries; i++) @@ -5416,15 +5682,27 @@ { REGISTER Ichar c; re_bool not_p = (re_opcode_t) *(p - 1) == charset_mule_not; + Bitbyte class_bits = *p++; DEBUG_MATCH_PRINT2 ("EXECUTING charset_mule%s.\n", not_p ? "_not" : ""); - REGEX_PREFETCH (); c = itext_ichar_fmt (d, fmt, lispobj); c = RE_TRANSLATE (c); /* The character to match. */ - if (EQ (Qt, unified_range_table_lookup (p, c, Qnil))) - not_p = !not_p; + if ((class_bits && + ((class_bits & BIT_ALPHA && ISALPHA (c)) + || (class_bits & BIT_SPACE && ISSPACE (c)) + || (class_bits & BIT_PUNCT && ISPUNCT (c)) + || (class_bits & BIT_WORD && ISWORD (c)) + || (TRANSLATE_P (translate) ? + (class_bits & (BIT_UPPER | BIT_LOWER) + && !NOCASEP (lispbuf, c)) + : ((class_bits & BIT_UPPER && ISUPPER (c)) + || (class_bits & BIT_LOWER && ISLOWER (c)))))) + || EQ (Qt, unified_range_table_lookup (p, c, Qnil))) + { + not_p = !not_p; + } p += unified_range_table_bytes_used (p);
--- a/src/regex.h Fri Aug 03 02:00:29 2012 +0900 +++ b/src/regex.h Fri Aug 03 02:05:08 2012 +0900 @@ -30,6 +30,8 @@ #define RE_LISP_CONTEXT_ARGS_DECL , Lisp_Object lispobj, struct buffer *lispbuf, struct syntax_cache *scache #define RE_LISP_CONTEXT_ARGS_MULE_DECL , Lisp_Object lispobj, struct buffer *USED_IF_MULE (lispbuf), struct syntax_cache *scache #define RE_LISP_CONTEXT_ARGS , lispobj, lispbuf, scache +#define RE_ISWCTYPE_ARG_DECL , struct buffer *lispbuf +#define RE_ISWCTYPE_ARG(varname) , varname #else #define RE_TRANSLATE_TYPE char * #define RE_LISP_SHORT_CONTEXT_ARGS_DECL @@ -37,6 +39,8 @@ #define RE_LISP_CONTEXT_ARGS_DECL #define RE_LISP_CONTEXT_ARGS_MULE_DECL #define RE_LISP_CONTEXT_ARGS +#define RE_ISWCTYPE_ARG_DECL +#define RE_ISWCTYPE_ARG(varname) #define Elemcount ssize_t #define Bytecount ssize_t #endif /* emacs */ @@ -193,7 +197,7 @@ (The [[[ comments delimit what gets put into the Texinfo file, so don't delete them!) */ /* [[[begin syntaxes]]] */ -#define RE_SYNTAX_EMACS RE_INTERVALS +#define RE_SYNTAX_EMACS (RE_INTERVALS | RE_CHAR_CLASSES) #define RE_SYNTAX_AWK \ (RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DOT_NOT_NULL \ @@ -546,6 +550,99 @@ extern int debug_regexps; +typedef enum + { + RECC_ERROR = 0, + RECC_ALNUM, RECC_ALPHA, RECC_WORD, + RECC_GRAPH, RECC_PRINT, + RECC_LOWER, RECC_UPPER, + RECC_PUNCT, RECC_CNTRL, + RECC_DIGIT, RECC_XDIGIT, + RECC_BLANK, RECC_SPACE, + RECC_MULTIBYTE, RECC_NONASCII, + RECC_ASCII, RECC_UNIBYTE +} re_wctype_t; + +#define CHAR_CLASS_MAX_LENGTH 9 /* Namely, `multibyte'. */ + +/* Map a string to the char class it names (if any). */ +re_wctype_t re_wctype (const char *); + +/* Is character CH a member of the character class CC? */ +int re_iswctype (int ch, re_wctype_t cc RE_ISWCTYPE_ARG_DECL); + +/* Bits used to implement the multibyte-part of the various character + classes such as [:alnum:] in a charset's range table. XEmacs; use an + enum, so they're visible in the debugger. */ +enum +{ + BIT_WORD = (1 << 0), + BIT_LOWER = (1 << 1), + BIT_PUNCT = (1 << 2), + BIT_SPACE = (1 << 3), + BIT_UPPER = (1 << 4), + /* XEmacs; we need this, because we unify treatment of ASCII and non-ASCII + (possible matches) in charset_mule. [:alpha:] matches all characters + with word syntax, with the exception of [0-9]. We don't need + BIT_MULTIBYTE. */ + BIT_ALPHA = (1 << 5) +}; + +#ifdef emacs +reg_errcode_t compile_char_class (re_wctype_t cc, Lisp_Object rtab, + Bitbyte *flags_out); + +#endif + +/* isalpha etc. are used for the character classes. */ +#include <ctype.h> + +#ifdef emacs + +/* 1 if C is an ASCII character. */ +#define ISASCII(c) ((c) < 0x80) + +/* 1 if C is a unibyte character. */ +#define ISUNIBYTE ISASCII + +/* The Emacs definitions should not be directly affected by locales. */ + +/* In Emacs, these are only used for single-byte characters. */ +#define ISDIGIT(c) ((c) >= '0' && (c) <= '9') +#define ISCNTRL(c) ((c) < ' ') +#define ISXDIGIT(c) (ISDIGIT (c) || ((c) >= 'a' && (c) <= 'f') \ + || ((c) >= 'A' && (c) <= 'F')) + +/* This is only used for single-byte characters. */ +#define ISBLANK(c) ((c) == ' ' || (c) == '\t') + +/* The rest must handle multibyte characters. */ + +#define ISGRAPH(c) ((c) > ' ' && (c) != 0x7f) +#define ISPRINT(c) ((c) == ' ' || ISGRAPH (c)) +#define ISALPHA(c) (ISASCII (c) ? (((c) >= 'a' && (c) <= 'z') \ + || ((c) >= 'A' && (c) <= 'Z')) \ + : ISWORD (c)) +#define ISALNUM(c) (ISALPHA (c) || ISDIGIT (c)) + +#define ISLOWER(c) LOWERCASEP (lispbuf, c) + +#define ISPUNCT(c) (ISASCII (c) \ + ? ((c) > ' ' && (c) < 0x7F \ + && !(((c) >= 'a' && (c) <= 'z') \ + || ((c) >= 'A' && (c) <= 'Z') \ + || ((c) >= '0' && (c) <= '9'))) \ + : !ISWORD (c)) + +#define ISSPACE(c) \ + (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Swhitespace) + +#define ISUPPER(c) UPPERCASEP (lispbuf, c) + +#define ISWORD(c) (SYNTAX (BUFFER_MIRROR_SYNTAX_TABLE (lispbuf), c) == Sword) + +#endif + END_C_DECLS #endif /* INCLUDED_regex_h_ */
--- a/src/search.c Fri Aug 03 02:00:29 2012 +0900 +++ b/src/search.c Fri Aug 03 02:05:08 2012 +0900 @@ -419,7 +419,7 @@ static Lisp_Object string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start, - struct buffer *buf, int UNUSED (posix)) + struct buffer *buf, int posix) { Bytecount val; Charcount s; @@ -450,7 +450,7 @@ bufp = compile_pattern (regexp, &search_regs, (!NILP (buf->case_fold_search) ? XCASE_TABLE_DOWNCASE (buf->case_table) : Qnil), - string, buf, 0, ERROR_ME); + string, buf, posix, ERROR_ME); QUIT; { Bytecount bis = string_index_char_to_byte (string, s); @@ -887,9 +887,9 @@ a range table. */ unsigned char fastmap[0400]; int negate = 0; - REGISTER int i; Charbpos limit; struct syntax_cache *scache; + Bitbyte class_bits = 0; if (NILP (lim)) limit = forwardp ? BUF_ZV (buf) : BUF_BEGV (buf); @@ -957,6 +957,51 @@ Vskip_chars_range_table); INC_IBYTEPTR (p); } + else if ('[' == c && p != pend && *p == ':') + { + Ibyte *colonp; + Extbyte *classname; + int ch = 0; + re_wctype_t cc; + + INC_IBYTEPTR (p); + + if (p == pend) + { + fastmap ['['] = fastmap[':'] = 1; + break; + } + + colonp = (Ibyte *) memchr (p, ':', pend - p); + if (NULL == colonp || (colonp + 1) == pend || colonp[1] != ']') + { + fastmap ['['] = fastmap[':'] = 1; + continue; + } + + classname = alloca_extbytes (colonp - p + 1); + memmove (classname, p, colonp - p); + classname[colonp - p] = '\0'; + cc = re_wctype (classname); + + if (cc == RECC_ERROR) + { + invalid_argument ("Invalid character class", + build_extstring (classname, Qbinary)); + } + + for (ch = 0; ch < countof (fastmap); ++ch) + { + if (re_iswctype (ch, cc, buf)) + { + fastmap[ch] = 1; + } + } + + compile_char_class (cc, Vskip_chars_range_table, &class_bits); + + p = colonp + 2; + } else { if (c < 0400) @@ -972,14 +1017,6 @@ if (syntaxp && fastmap['-'] != 0) fastmap[' '] = 1; - /* If ^ was the first character, complement the fastmap. - We don't complement the range table, however; we just use negate - in the comparisons below. */ - - if (negate) - for (i = 0; i < (int) (sizeof (fastmap)); i++) - fastmap[i] ^= 1; - { Charbpos start_point = BUF_PT (buf); Charbpos pos = start_point; @@ -996,7 +1033,8 @@ while (fastmap[(unsigned char) syntax_code_spec [(int) SYNTAX_FROM_CACHE - (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]]) + (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]] + != negate) { pos++; INC_BYTEBPOS (buf, pos_byte); @@ -1013,10 +1051,11 @@ pos--; DEC_BYTEBPOS (buf, pos_byte); UPDATE_SYNTAX_CACHE_BACKWARD (scache, pos); - if (!fastmap[(unsigned char) - syntax_code_spec - [(int) SYNTAX_FROM_CACHE - (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]]) + if (fastmap[(unsigned char) + syntax_code_spec + [(int) SYNTAX_FROM_CACHE + (scache, BYTE_BUF_FETCH_CHAR (buf, pos_byte))]] + == negate) { pos++; pos_byte = savepos; @@ -1027,16 +1066,30 @@ } else { + struct buffer *lispbuf = buf; + +#define CLASS_BIT_CHECK(c) \ + (class_bits && ((class_bits & BIT_ALPHA && ISALPHA (c)) \ + || (class_bits & BIT_SPACE && ISSPACE (c)) \ + || (class_bits & BIT_PUNCT && ISPUNCT (c)) \ + || (class_bits & BIT_WORD && ISWORD (c)) \ + || (NILP (buf->case_fold_search) ? \ + ((class_bits & BIT_UPPER && ISUPPER (c)) \ + || (class_bits & BIT_LOWER && ISLOWER (c))) \ + : (class_bits & (BIT_UPPER | BIT_LOWER) \ + && !NOCASEP (buf, c))))) if (forwardp) { while (pos < limit) { Ichar ch = BYTE_BUF_FETCH_CHAR (buf, pos_byte); - if ((ch < 0400) ? fastmap[ch] : - (NILP (Fget_range_table (make_fixnum (ch), - Vskip_chars_range_table, - Qnil)) - == negate)) + + if ((ch < countof (fastmap) ? fastmap[ch] + : (CLASS_BIT_CHECK (ch) || + (EQ (Qt, Fget_range_table (make_fixnum (ch), + Vskip_chars_range_table, + Qnil))))) + != negate) { pos++; INC_BYTEBPOS (buf, pos_byte); @@ -1054,11 +1107,12 @@ DEC_BYTEBPOS (buf, prev_pos_byte); ch = BYTE_BUF_FETCH_CHAR (buf, prev_pos_byte); - if ((ch < 0400) ? fastmap[ch] : - (NILP (Fget_range_table (make_fixnum (ch), - Vskip_chars_range_table, - Qnil)) - == negate)) + if ((ch < countof (fastmap) ? fastmap[ch] + : (CLASS_BIT_CHECK (ch) || + (EQ (Qt, Fget_range_table (make_fixnum (ch), + Vskip_chars_range_table, + Qnil))))) + != negate) { pos--; pos_byte = prev_pos_byte;
--- a/tests/ChangeLog Fri Aug 03 02:00:29 2012 +0900 +++ b/tests/ChangeLog Fri Aug 03 02:05:08 2012 +0900 @@ -1,3 +1,46 @@ +2012-05-12 Aidan Kehoe <kehoea@parhasard.net> + + * automated/mule-tests.el: + Test #'truncate-string-to-width, thank you Colin Walters. + +2012-05-06 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el: + Use &environment appropriately in #'macrolet, instead of relying + on #'macroexpand to guess what we mean. + +2012-05-04 Aidan Kehoe <kehoea@parhasard.net> + + * automated/regexp-tests.el (equal): + * automated/regexp-tests.el (Assert-char-class): + Correct a stray parenthesis; add tests for the predefined + character classes with #'skip-chars-{forward,backward}; update the + tests to reflect some changed design decisions on my part. + +2012-04-25 Aidan Kehoe <kehoea@parhasard.net> + + * automated/regexp-tests.el: Check that #'posix-string-match + actually returns the longest match; thank you Ilya Shlyakhter in + jn1j8t$ujq$1@dough.gmane.org ! + +2012-04-21 Aidan Kehoe <kehoea@parhasard.net> + + * automated/regexp-tests.el: + * automated/regexp-tests.el (Assert-char-class): + Check that #'string-match errors correctly with an over-long + character class name. + Add tests for character class functionality that supports + non-ASCII characters. These tests expose bugs in GNU Emacs + 24.0.94.2, but pass under current XEmacs. + +2012-04-21 Aidan Kehoe <kehoea@parhasard.net> + + * automated/regexp-tests.el: + * automated/regexp-tests.el (Assert-char-class): + Test the character classes functionality that was always in + regex.c but that has only just been turned on. These tests pass on + GNU Emacs 24.0.94.2. + 2012-01-14 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el:
--- a/tests/automated/lisp-tests.el Fri Aug 03 02:00:29 2012 +0900 +++ b/tests/automated/lisp-tests.el Fri Aug 03 02:05:08 2012 +0900 @@ -2957,10 +2957,10 @@ (append form (list 1 [hi there] 40 "this is a string" pi))) (with-second-arguments (&optional form) (append form (list pi e ''hello ''there [40 50 60]))) - (with-both-arguments (&optional form) + (with-both-arguments (&optional form &environment env) (append form - (macroexpand '(with-first-arguments)) - (macroexpand '(with-second-arguments))))) + (macroexpand '(with-first-arguments) env) + (macroexpand '(with-second-arguments) env)))) (with-temp-buffer (Assert @@ -2986,4 +2986,20 @@ (Assert (not (funcall (intern "eq") #'bookend #'refer-to-bookend)) "checking two mutually recursive functions compiled OK")))) +;; Test macroexpand's handling of the ENVIRONMENT argument. We augmented it +;; quietly for about four months, and this was incorrect. + +(Check-Error + void-variable + (macrolet + ((with-first-arguments (&optional form) + (append form (list 1 [hi there] 40 "this is a string" pi))) + (with-second-arguments (&optional form) + (append form (list pi e ''hello ''there [40 50 60]))) + (with-both-arguments (&optional form) + (append form + (macroexpand '(with-first-arguments)) + (macroexpand '(with-second-arguments))))) + (with-both-arguments (list)))) + ;;; end of lisp-tests.el
--- a/tests/automated/mule-tests.el Fri Aug 03 02:00:29 2012 +0900 +++ b/tests/automated/mule-tests.el Fri Aug 03 02:05:08 2012 +0900 @@ -808,7 +808,81 @@ (Assert (let (default-process-coding-system) (shell-command "cat </dev/null >/dev/null") t)))) - + ;;; Test suite for truncate-string-to-width, from Colin Walters' tests in + ;;; mult-util.el in GNU. + (macrolet + ((test-truncate-string-to-width (&rest tests) + (let ((decode-any-string + ;; We can't store the East Asian characters directly in this + ;; file, since it needs to be read (but not executed) by + ;; non-Mule. Store them as UTF-8, decode them at + ;; macro-expansion time. + #'(lambda (object) + (if (stringp object) + (decode-coding-string object 'utf-8) + object)))) + (cons + 'progn + (mapcar + (function* + (lambda ((arguments . result)) + `(Assert (equal (truncate-string-to-width + ,@(mapcar decode-any-string arguments)) + ,(funcall decode-any-string result))))) + tests))))) + (test-truncate-string-to-width + (("" 0) . "") + (("x" 1) . "x") + (("xy" 1) . "x") + (("xy" 2 1) . "y") + (("xy" 0) . "") + (("xy" 3) . "xy") + (("\344\270\255" 0) . "") + (("\344\270\255" 1) . "") + (("\344\270\255" 2) . "\344\270\255") + (("\344\270\255" 1 nil ? ) . " ") + (("\344\270\255\346\226\207" 3 1 ? ) . " ") + (("x\344\270\255x" 2) . "x") + (("x\344\270\255x" 3) . "x\344\270\255") + (("x\344\270\255x" 3) . "x\344\270\255") + (("x\344\270\255x" 4 1) . "\344\270\255x") + (("kor\355\225\234e\352\270\200an" 8 1 ? ) . + "or\355\225\234e\352\270\200") + (("kor\355\225\234e\352\270\200an" 7 2 ? ) . "r\355\225\234e ") + (("" 0 nil nil "...") . "") + (("x" 3 nil nil "...") . "x") + (("\344\270\255" 3 nil nil "...") . "\344\270\255") + (("foo" 3 nil nil "...") . "foo") + (("foo" 2 nil nil "...") . "fo") ;; (old) XEmacs failure? + (("foobar" 6 0 nil "...") . "foobar") + (("foobarbaz" 6 nil nil "...") . "foo...") + (("foobarbaz" 7 2 nil "...") . "ob...") + (("foobarbaz" 9 3 nil "...") . "barbaz") + (("\343\201\223h\343\202\223e\343\201\253l\343\201\241l\343\201\257o" 15 + 1 ? t) . " h\343\202\223e\343\201\253l\343\201\241l\343\201\257o") + (("\343\201\223h\343\202\223e\343\201\253l\343\201\241l\343\201\257o" 14 + 1 ? t) . " h\343\202\223e\343\201\253l\343\201\241...") + (("x" 3 nil nil "\347\262\265\350\252\236") . "x") + (("\344\270\255" 2 nil nil "\347\262\265\350\252\236") . "\344\270\255") + ;; XEmacs used to error + (("\344\270\255" 1 nil ?x "\347\262\265\350\252\236") . "x") + (("\344\270\255\346\226\207" 3 nil ? "\347\262\265\350\252\236") . + ;; XEmacs used to error + "\344\270\255 ") + (("foobarbaz" 4 nil nil "\347\262\265\350\252\236") . + "\347\262\265\350\252\236") + (("foobarbaz" 5 nil nil "\347\262\265\350\252\236") . + "f\347\262\265\350\252\236") + (("foobarbaz" 6 nil nil "\347\262\265\350\252\236") . + "fo\347\262\265\350\252\236") + (("foobarbaz" 8 3 nil "\347\262\265\350\252\236") . + "b\347\262\265\350\252\236") + (("\343\201\223h\343\202\223e\343\201\253l\343\201\241l\343\201\257o" 14 + 4 ?x "\346\227\245\346\234\254\350\252\236") . + "xe\343\201\253\346\227\245\346\234\254\350\252\236") + (("\343\201\223h\343\202\223e\343\201\253l\343\201\241l\343\201\257o" 13 + 4 ?x "\346\227\245\346\234\254\350\252\236") . + "xex\346\227\245\346\234\254\350\252\236"))) ) ; end of tests that require MULE built in. ;;; end of mule-tests.el
--- a/tests/automated/regexp-tests.el Fri Aug 03 02:00:29 2012 +0900 +++ b/tests/automated/regexp-tests.el Fri Aug 03 02:05:08 2012 +0900 @@ -69,6 +69,15 @@ (Assert (string-match "Ä" "Ä")) (Assert (not (string-match "Ä" "ä")))) +;; Is posix-string-match passing the POSIX flag correctly? + +(Assert + (equal + (save-match-data + (progn (posix-string-match "i\\|ii" "ii") (match-data))) + '(0 2)) + "checking #'posix-string-match actually returns the longest match") + ;; looking-at (with-temp-buffer (insert "äÄ") @@ -596,3 +605,507 @@ (Assert (eql (string-match "[\x7f\x80\x9f]" "\x80") 0)) (Assert (eql (string-match "[\x7e\x80-\x9f]" "\x80") 0)) (Assert (eql (string-match "[\x7f\x81-\x9f]" "\x81") 0)) + +;; Test character classes + +;; This used not to error: +(Check-Error-Message invalid-regexp "Invalid character class name" + (string-match "[[:alnum12345:]]" "a")) +;; This alwayed errored, as long as character classes were turned on +(Check-Error-Message invalid-regexp "Invalid character class name" + (string-match "[[:alnum1234:]]" "a")) + +(macrolet + ((Assert-char-class (class matching-char non-matching-char) + (if (and (not (featurep 'mule)) + (or (eq (car-safe matching-char) 'decode-char) + (eq (car-safe non-matching-char) 'decode-char))) + ;; Don't attempt expansion if these clauses require Mule and we + ;; don't have it. + (return-from Assert-char-class nil) + (setq matching-char (eval matching-char) + non-matching-char (eval non-matching-char))) + `(progn + (Assert (eql (string-match ,(concat "[" class "]") + ,(concat (string matching-char) + (string non-matching-char))) + 0)) + (Assert (eql (string-match ,(concat "[" class class class "]") + ,(concat (string matching-char) + (string non-matching-char))) + 0)) + (Assert (eql (string-match ,(concat "[^" class "]") + ,(concat (string non-matching-char) + (string matching-char))) + 0)) + (Assert (eql (string-match ,(concat "[^" class class class "]") + ,(concat (string non-matching-char) + (string matching-char))) + 0)) + (Assert (eql (string-match ,(concat "[" class "]") + ,(concat (string non-matching-char) + (string matching-char))) + 1)) + (Assert (eql (string-match ,(concat "[" class class class "]") + ,(concat (string non-matching-char) + (string matching-char))) + 1)) + (Assert (eql (string-match ,(concat "[^" class "]") + ,(concat (string matching-char) + (string non-matching-char))) + 1)) + (Assert (eql (string-match ,(concat "[^" class class class "]") + ,(concat (string matching-char) + (string non-matching-char))) + 1)) + (Assert (null (string-match ,(concat "[" class "]") + ,(string non-matching-char)))) + (Assert (null (string-match ,(concat "[^" class "]") + ,(string matching-char)))) + (Assert (null (string-match ,(concat "[^" class + (string non-matching-char) "]") + ,(concat (string matching-char) + (string non-matching-char))))) + (let ((old-case-fold-search case-fold-search)) + (with-temp-buffer + (setq case-fold-search old-case-fold-search) + (insert-char ,matching-char 20) + (insert-char ,non-matching-char 20) + (goto-char (point-min)) + (Assert (eql (skip-chars-forward ,class) 20) + ,(format "making sure %s skips %S forward" + class matching-char)) + (Assert (eql (skip-chars-forward ,(concat "^" class)) 20) + ,(format "making sure ^%s skips %S forward" + class non-matching-char)) + (Assert (eql (skip-chars-backward ,(concat "^" class)) -20) + ,(format "making sure ^%s skips %S backward" + class non-matching-char)) + (Assert (eql (skip-chars-backward ,class) -20) + ,(format "making sure %s skips %S backward" + class matching-char)))))) + (Assert-never-matching (class &rest characters) + (cons + 'progn + (mapcan #'(lambda (character) + (if (or (not (eq 'decode-char (car-safe character))) + (featurep 'mule)) + `((Assert (null (string-match + ,(concat "[" class "]") + ,(string (eval character))))) + (Assert (eql (string-match + ,(concat "[^" class "]") + ,(string (eval character))) + 0))))) + characters)))) + (Assert-char-class "[:alpha:]" ?a ?0) + (Assert-char-class "[:alpha:]" ?z ?9) + (Assert-char-class "[:alpha:]" ?A ?0) + (Assert-char-class "[:alpha:]" ?Z ?9) + (Assert-char-class "[:alpha:]" ?b ?\x00) + (Assert-char-class "[:alpha:]" ?c ?\x09) + (Assert-char-class "[:alpha:]" ?d ?\ ) + (Assert-char-class "[:alpha:]" ?e ?\x7f) + (Assert-char-class + "[:alpha:]" + (decode-char 'ucs #x0430) ;; CYRILLIC SMALL LETTER A + (decode-char 'ucs #x2116)) ;; NUMERO SIGN + (Assert-char-class + "[:alpha:]" + (decode-char 'ucs #x0410) ;; CYRILLIC CAPITAL LETTER A + ?\x02) + (Assert-char-class + "[:alpha:]" + (decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA + (decode-char 'ucs #x0385)) ;; GREEK DIALYTIKA TONOS + + (Assert-char-class "[:alnum:]" ?a ?.) + (Assert-char-class "[:alnum:]" ?z ?') + (Assert-char-class "[:alnum:]" ?A ?/) + (Assert-char-class "[:alnum:]" ?Z ?!) + (Assert-char-class "[:alnum:]" ?0 ?,) + (Assert-char-class "[:alnum:]" ?9 ?\t) + (Assert-char-class "[:alnum:]" ?b ?\x00) + (Assert-char-class "[:alnum:]" ?c ?\x09) + (Assert-char-class "[:alnum:]" ?d ?\ ) + (Assert-char-class "[:alnum:]" ?e ?\x7f) + (Assert-char-class + "[:alnum:]" + (decode-char 'ucs #x0430) ;; CYRILLIC SMALL LETTER A + (decode-char 'ucs #x2116)) ;; NUMERO SIGN + (Assert-char-class + "[:alnum:]" + (decode-char 'ucs #x0410) ;; CYRILLIC CAPITAL LETTER A + ?\x02) + (Assert-char-class + "[:alnum:]" + (decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA + (decode-char 'ucs #x0385)) ;; GREEK DIALYTIKA TONOS + + (Assert-char-class "[:word:]" ?a ?.) + (Assert-char-class "[:word:]" ?z ?') + (Assert-char-class "[:word:]" ?A ?/) + (Assert-char-class "[:word:]" ?Z ?!) + (Assert-char-class "[:word:]" ?0 ?,) + (Assert-char-class "[:word:]" ?9 ?\t) + (Assert-char-class "[:word:]" ?b ?\x00) + (Assert-char-class "[:word:]" ?c ?\x09) + (Assert-char-class "[:word:]" ?d ?\ ) + (Assert-char-class "[:word:]" ?e ?\x7f) + (Assert-char-class + "[:word:]" + (decode-char 'ucs #x0430) ;; CYRILLIC SMALL LETTER A + (decode-char 'ucs #x2116)) ;; NUMERO SIGN + (Assert-char-class + "[:word:]" + (decode-char 'ucs #x0410) ;; CYRILLIC CAPITAL LETTER A + ?\x02) + (Assert-char-class + "[:word:]" + (decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA + (decode-char 'ucs #x0385)) ;; GREEK DIALYTIKA TONOS + + (let ((case-fold-search nil)) + (Assert-char-class "[:upper:]" ?A ?a) + (Assert-char-class "[:upper:]" ?Z ?z) + (Assert-char-class "[:upper:]" ?B ?0) + (Assert-char-class "[:upper:]" ?C ?9) + (Assert-char-class "[:upper:]" ?D ?\x00) + (Assert-char-class "[:upper:]" ?E ?\x09) + (Assert-char-class "[:upper:]" ?F ?\ ) + (Assert-char-class "[:upper:]" ?G ?\x7f) + (Assert-char-class + "[:upper:]" + (decode-char 'ucs #x0410) ;; CYRILLIC CAPITAL LETTER A + (decode-char 'ucs #x0686)) ;; ARABIC LETTER TCHEH + (Assert-char-class + "[:upper:]" + (decode-char 'ucs #x0392) ;; GREEK CAPITAL LETTER BETA + (decode-char 'ucs #x5357)) ;; kDefinition south; southern part; southward + + (Assert-char-class "[:lower:]" ?a ?A) + (Assert-char-class "[:lower:]" ?z ?Z) + (Assert-char-class "[:lower:]" ?b ?0) + (Assert-char-class "[:lower:]" ?c ?9) + (Assert-char-class "[:lower:]" ?d ?\x00) + (Assert-char-class "[:lower:]" ?e ?\x09) + (Assert-char-class "[:lower:]" ?f ? ) + (Assert-char-class "[:lower:]" ?g ?\x7f) + (Assert-char-class + "[:lower:]" + (decode-char 'ucs #x0430) ;; CYRILLIC SMALL LETTER A + (decode-char 'ucs #x0686)) ;; ARABIC LETTER TCHEH + (Assert-char-class + "[:lower:]" + (decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA + (decode-char 'ucs #x5357)));; kDefinition south; southern part; southward + + (let ((case-fold-search t)) + (Assert-char-class "[:upper:]" ?a ?\x00) + (Assert-char-class "[:upper:]" ?z ?\x01) + (Assert-char-class "[:upper:]" ?b ?{) + (Assert-char-class "[:upper:]" ?c ?}) + (Assert-char-class "[:upper:]" ?d ?<) + (Assert-char-class "[:upper:]" ?e ?>) + (Assert-char-class "[:upper:]" ?f ?\ ) + (Assert-char-class "[:upper:]" ?g ?\x7f) + (Assert-char-class + "[:upper:]" + (decode-char 'ucs #x0430) ;; CYRILLIC SMALL LETTER A + (decode-char 'ucs #x0686)) ;; ARABIC LETTER TCHEH + (Assert-char-class + "[:upper:]" + (decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA + (decode-char 'ucs #x5357)) ;; kDefinition south; southern part; southward + (Assert-char-class "[:lower:]" ?A ?\x00) + (Assert-char-class "[:lower:]" ?Z ?\x01) + (Assert-char-class "[:lower:]" ?B ?{) + (Assert-char-class "[:lower:]" ?C ?}) + (Assert-char-class "[:lower:]" ?D ?<) + (Assert-char-class "[:lower:]" ?E ?>) + (Assert-char-class "[:lower:]" ?F ?\ ) + (Assert-char-class "[:lower:]" ?G ?\x7F) + (Assert-char-class + "[:lower:]" + (decode-char 'ucs #x0410) ;; CYRILLIC CAPITAL LETTER A + (decode-char 'ucs #x0686)) ;; ARABIC LETTER TCHEH + (Assert-char-class + "[:lower:]" + (decode-char 'ucs #x0392) ;; GREEK CAPITAL LETTER BETA + (decode-char 'ucs #x5357)));; kDefinition south; southern part; southward + + (Assert-char-class "[:digit:]" ?0 ?a) + (Assert-char-class "[:digit:]" ?9 ?z) + (Assert-char-class "[:digit:]" ?1 ?A) + (Assert-char-class "[:digit:]" ?2 ?Z) + (Assert-char-class "[:digit:]" ?3 ?\x00) + (Assert-char-class "[:digit:]" ?4 ?\x09) + (Assert-char-class "[:digit:]" ?5 ? ) + (Assert-char-class "[:digit:]" ?6 ?\x7f) + (Assert-char-class + "[:digit:]" ?7 + (decode-char 'ucs #x0385)) ;; GREEK DIALYTIKA TONOS + (Assert-char-class + "[:digit:]" ?8 + (decode-char 'ucs #x0392)) ;; GREEK CAPITAL LETTER BETA + (Assert-char-class + "[:digit:]" ?9 + (decode-char 'ucs #x03B2)) ;; GREEK SMALL LETTER BETA + (Assert-char-class + "[:digit:]" ?0 + (decode-char 'ucs #x0410)) ;; CYRILLIC CAPITAL LETTER A + (Assert-char-class + "[:digit:]" ?1 + (decode-char 'ucs #x0430)) ;; CYRILLIC SMALL LETTER A + (Assert-char-class + "[:digit:]" ?2 + (decode-char 'ucs #x0686)) ;; ARABIC LETTER TCHEH + (Assert-char-class + "[:digit:]" ?3 + (decode-char 'ucs #x2116)) ;; NUMERO SIGN + (Assert-char-class + "[:digit:]" ?4 + (decode-char 'ucs #x5357)) ;; kDefinition south; southern part; southward + + (Assert-char-class "[:xdigit:]" ?0 ?g) + (Assert-char-class "[:xdigit:]" ?9 ?G) + (Assert-char-class "[:xdigit:]" ?A ?{) + (Assert-char-class "[:xdigit:]" ?a ?}) + (Assert-char-class "[:xdigit:]" ?1 ? ) + (Assert-char-class "[:xdigit:]" ?2 ?Z) + (Assert-char-class "[:xdigit:]" ?3 ?\x00) + (Assert-char-class "[:xdigit:]" ?4 ?\x09) + (Assert-char-class "[:xdigit:]" ?5 ?\x7f) + (Assert-char-class "[:xdigit:]" ?6 ?z) + (Assert-char-class + "[:xdigit:]" ?7 + (decode-char 'ucs #x0385)) ;; GREEK DIALYTIKA TONOS + (Assert-char-class + "[:xdigit:]" ?8 + (decode-char 'ucs #x0392)) ;; GREEK CAPITAL LETTER BETA + (Assert-char-class + "[:xdigit:]" ?9 + (decode-char 'ucs #x03B2)) ;; GREEK SMALL LETTER BETA + (Assert-char-class + "[:xdigit:]" ?a + (decode-char 'ucs #x0410)) ;; CYRILLIC CAPITAL LETTER A + (Assert-char-class + "[:xdigit:]" ?B + (decode-char 'ucs #x0430)) ;; CYRILLIC SMALL LETTER A + (Assert-char-class + "[:xdigit:]" ?c + (decode-char 'ucs #x0686)) ;; ARABIC LETTER TCHEH + (Assert-char-class + "[:xdigit:]" ?D + (decode-char 'ucs #x2116)) ;; NUMERO SIGN + (Assert-char-class + "[:xdigit:]" ?e + (decode-char 'ucs #x5357)) ;; kDefinition south; southern part; southward + + (Assert-char-class "[:space:]" ?\ ?0) + (Assert-char-class "[:space:]" ?\t ?9) + (Assert-char-class "[:space:]" ?\ ?A) + (Assert-char-class "[:space:]" ?\t ?Z) + (Assert-char-class "[:space:]" ?\ ?\x00) + (Assert-char-class "[:space:]" ?\ ?\x7f) + (Assert-char-class "[:space:]" ?\t ?a) + (Assert-char-class "[:space:]" ?\ ?z) + (Assert-char-class + "[:space:]" ?\ + (decode-char 'ucs #x0385)) ;; GREEK DIALYTIKA TONOS + (Assert-char-class + "[:space:]" ?\t + (decode-char 'ucs #x0392)) ;; GREEK CAPITAL LETTER BETA + (Assert-char-class + "[:space:]" ?\ + (decode-char 'ucs #x03B2)) ;; GREEK SMALL LETTER BETA + (Assert-char-class + "[:space:]" ?\t + (decode-char 'ucs #x0410)) ;; CYRILLIC CAPITAL LETTER A + (Assert-char-class + "[:space:]" ?\ + (decode-char 'ucs #x0430)) ;; CYRILLIC SMALL LETTER A + (Assert-char-class + "[:space:]" ?\t + (decode-char 'ucs #x0686)) ;; ARABIC LETTER TCHEH + (Assert-char-class + "[:space:]" ?\ + (decode-char 'ucs #x2116)) ;; NUMERO SIGN + (Assert-char-class + "[:space:]" ?\t + (decode-char 'ucs #x5357)) ;; kDefinition south; southern part; southward + + (Assert-char-class "[:print:]" ?\ ?\x00) + (Assert-char-class "[:print:]" ?0 ?\x09) + (Assert-char-class "[:print:]" ?9 ?\x7f) + (Assert-char-class "[:print:]" ?A ?\x01) + (Assert-char-class "[:print:]" ?Z ?\x02) + (Assert-char-class "[:print:]" ?B ?\t) + (Assert-char-class "[:print:]" ?a ?\x03) + (Assert-char-class "[:print:]" ?z ?\x04) + (Assert-char-class + "[:print:]" (decode-char 'ucs #x0385) ;; GREEK DIALYTIKA TONOS + ?\x05) + (Assert-char-class + "[:print:]" (decode-char 'ucs #x0392) ;; GREEK CAPITAL LETTER BETA + ?\x06) + (Assert-char-class + "[:print:]" (decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA + ?\x07) + (Assert-char-class + "[:print:]" (decode-char 'ucs #x0410) ;; CYRILLIC CAPITAL LETTER A + ?\x08) + (Assert-char-class + "[:print:]" (decode-char 'ucs #x0430) ;; CYRILLIC SMALL LETTER A + ?\x09) + (Assert-char-class + "[:print:]" (decode-char 'ucs #x0686) ;; ARABIC LETTER TCHEH + ?\x0a) + (Assert-char-class + "[:print:]" (decode-char 'ucs #x2116) ;; NUMERO SIGN + ?\x0b) + (Assert-char-class + "[:print:]" (decode-char 'ucs #x5357) ;; kDefinition south; southern part; southward + ?\x0c) + + (Assert-char-class "[:graph:]" ?! ?\ ) + (Assert-char-class "[:graph:]" ?0 ?\x09) + (Assert-char-class "[:graph:]" ?9 ?\x7f) + (Assert-char-class "[:graph:]" ?A ?\x01) + (Assert-char-class "[:graph:]" ?Z ?\x02) + (Assert-char-class "[:graph:]" ?B ?\t) + (Assert-char-class "[:graph:]" ?a ?\x03) + (Assert-char-class "[:graph:]" ?z ?\x04) + (Assert-char-class + "[:graph:]" (decode-char 'ucs #x0385) ;; GREEK DIALYTIKA TONOS + ?\x05) + (Assert-char-class + "[:graph:]" (decode-char 'ucs #x0392) ;; GREEK CAPITAL LETTER BETA + ?\x06) + (Assert-char-class + "[:graph:]" (decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA + ?\x07) + (Assert-char-class + "[:graph:]" (decode-char 'ucs #x0410) ;; CYRILLIC CAPITAL LETTER A + ?\x08) + (Assert-char-class + "[:graph:]" (decode-char 'ucs #x0430) ;; CYRILLIC SMALL LETTER A + ?\x09) + (Assert-char-class + "[:graph:]" (decode-char 'ucs #x0686) ;; ARABIC LETTER TCHEH + ?\x0a) + (Assert-char-class + "[:graph:]" (decode-char 'ucs #x2116) ;; NUMERO SIGN + ?\x0b) + (Assert-char-class + "[:graph:]" (decode-char 'ucs #x5357) ;; kDefinition south; southern part; southward + ?\x0c) + + (Assert-char-class "[:punct:]" ?\( ?0) + (Assert-char-class "[:punct:]" ?. ?9) + (Assert-char-class "[:punct:]" ?{ ?A) + (Assert-char-class "[:punct:]" ?} ?Z) + (Assert-char-class "[:punct:]" ?: ?\t) + (Assert-char-class "[:punct:]" ?\; ?\x00) + (Assert-char-class "[:punct:]" ?< ?\x09) + (Assert-char-class "[:punct:]" ?> ?\x7f) + (Assert-char-class "[:punct:]" ?= ?a) + (Assert-char-class "[:punct:]" ?\? ?z) + (Assert-char-class + "[:punct:]" + (decode-char 'ucs #x0385) ;; GREEK DIALYTIKA TONOS + ?a) + (Assert-char-class + "[:punct:]" + (decode-char 'ucs #x20af) ;; DRACHMA SIGN + (decode-char 'ucs #x0392)) ;; GREEK CAPITAL LETTER BETA + (Assert-char-class + "[:punct:]" + (decode-char 'ucs #x00a7) ;; SECTION SIGN + (decode-char 'ucs #x03B2)) ;; GREEK SMALL LETTER BETA + (Assert-char-class + "[:punct:]" + (decode-char 'ucs #x00a8) ;; DIAERESIS + (decode-char 'ucs #x0410)) ;; CYRILLIC CAPITAL LETTER A + (Assert-char-class + "[:punct:]" + (decode-char 'ucs #x0384) ;; GREEK TONOS + (decode-char 'ucs #x0430)) ;; CYRILLIC SMALL LETTER A + (Assert-char-class + "[:punct:]" + (decode-char 'ucs #x00b7) ;; MIDDLE DOT + (decode-char 'ucs #x0686)) ;; ARABIC LETTER TCHEH + (Assert-char-class + "[:punct:]" + (decode-char 'ucs #x2116) ;; NUMERO SIGN + ?x) + (Assert-char-class + "[:punct:]" + ?= + (decode-char 'ucs #x5357)) ;; kDefinition south; southern part; southward + + (Assert-char-class "[:ascii:]" ?a (decode-char 'ucs #x00a7)) ;; SECTION SIGN + (Assert-char-class "[:ascii:]" ?b (decode-char 'ucs #x00a8)) ;; DIAERESIS + (Assert-char-class "[:ascii:]" ?c (decode-char 'ucs #x00b7)) ;; MIDDLE DOT + (Assert-char-class "[:ascii:]" ?d (decode-char 'ucs #x0384)) ;; GREEK TONOS + (Assert-char-class + "[:ascii:]" ?\x00 (decode-char 'ucs #x0392)) ;; GREEK CAPITAL LETTER BETA + (Assert-char-class + "[:ascii:]" ?\x01 (decode-char 'ucs #x03B2)) ;; GREEK SMALL LETTER BETA + (Assert-char-class + "[:ascii:]" ?\t (decode-char 'ucs #x0410)) ;; CYRILLIC CAPITAL LETTER A + (Assert-char-class + "[:ascii:]" ?A (decode-char 'ucs #x0430)) ;; CYRILLIC SMALL LETTER A + (Assert-char-class + "[:ascii:]" ?B (decode-char 'ucs #x0686)) ;; ARABIC LETTER TCHEH + (Assert-char-class + "[:ascii:]" ?C (decode-char 'ucs #x20af)) ;; DRACHMA SIGN + (Assert-char-class + "[:ascii:]" ?\x7f (decode-char 'ucs #x2116)) ;; NUMERO SIGN + + (Assert-char-class + "[:nonascii:]" (decode-char 'ucs #x00a7) ?a) ;; SECTION SIGN + (Assert-char-class + "[:nonascii:]" (decode-char 'ucs #x00a8) ?b) ;; DIAERESIS + (Assert-char-class + "[:nonascii:]" (decode-char 'ucs #x00b7) ?c) ;; MIDDLE DOT + (Assert-char-class + "[:nonascii:]" (decode-char 'ucs #x0384) ?d) ;; GREEK TONOS + (Assert-char-class + "[:nonascii:]" (decode-char 'ucs #x0392) ?\x00) ;; GREEK CAPITAL LETTER BETA + (Assert-char-class + "[:nonascii:]" (decode-char 'ucs #x03B2) ?\x01) ;; GREEK SMALL LETTER BETA + (Assert-char-class + "[:nonascii:]" (decode-char 'ucs #x0410) ?\t) ;; CYRILLIC CAPITAL LETTER A + (Assert-char-class + "[:nonascii:]" (decode-char 'ucs #x0430) ?A) ;; CYRILLIC SMALL LETTER A + (Assert-char-class + "[:nonascii:]" (decode-char 'ucs #x0686) ?B) ;; ARABIC LETTER TCHEH + (Assert-char-class + "[:nonascii:]" (decode-char 'ucs #x20af) ?C) ;; DRACHMA SIGN + (Assert-char-class + "[:nonascii:]" (decode-char 'ucs #x2116) ?\x7f) ;; NUMERO SIGN + + (Assert-char-class + "[:multibyte:]" (decode-char 'ucs #x00a7) ?a) ;; SECTION SIGN + (Assert-char-class + "[:multibyte:]" (decode-char 'ucs #x00a8) ?b) ;; DIAERESIS + (Assert-char-class + "[:multibyte:]" (decode-char 'ucs #x00b7) ?c) ;; MIDDLE DOT + (Assert-char-class + "[:multibyte:]" (decode-char 'ucs #x0384) ?d) ;; GREEK TONOS + (Assert-char-class + "[:multibyte:]" (decode-char 'ucs #x0392) + ?\x00) ;; GREEK CAPITAL LETTER BETA + + (Assert-never-matching + "[:unibyte:]" + ?\x80 ?\xe4 ?\xdf ?\xf8 + (decode-char 'ucs #x03B2) ;; GREEK SMALL LETTER BETA + (decode-char 'ucs #x0410) ;; CYRILLIC CAPITAL LETTER A + (decode-char 'ucs #x0430) ;; CYRILLIC SMALL LETTER A + (decode-char 'ucs #x0686) ;; ARABIC LETTER TCHEH + (decode-char 'ucs #x20af) ;; DRACHMA SIGN + (decode-char 'ucs #x2116) ;; NUMERO SIGN + (decode-char 'ucs #x5357))) ;; kDefinition south; southern part; southward +