Mercurial > hg > xemacs-beta
changeset 5567:3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
lisp/ChangeLog addition:
2011-09-07 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (transpose-subr):
* specifier.el (let-specifier):
* specifier.el (derive-device-type-from-tag-set):
* test-harness.el (batch-test-emacs):
* x-compose.el (alias-colon-to-doublequote):
* mule/chinese.el (make-chinese-cns11643-charset):
* mule/mule-cmds.el (set-locale-for-language-environment):
* mule/mule-cmds.el (set-language-environment-coding-systems):
* mule/mule-x-init.el (x-use-halfwidth-roman-font):
* about.el (about-xemacs):
* about.el (about-hackers):
* diagnose.el (show-memory-usage):
* diagnose.el (show-object-memory-usage-stats):
* diagnose.el (show-mc-alloc-memory-usage):
* diagnose.el (show-gc-stats):
* dialog.el (make-dialog-box):
* faces.el:
* faces.el (Face-frob-property):
* faces.el (set-face-stipple):
* glyphs.el:
* glyphs.el (init-glyphs): Removed.
* help-macro.el (make-help-screen):
* info.el (Info-construct-menu):
* keymap.el (key-sequence-list-description):
* lisp-mode.el (construct-lisp-mode-menu):
* loadhist.el (unload-feature):
* minibuf.el (get-user-response):
* mouse.el (default-mouse-track-check-for-activation):
* mouse.el (mouse-track-insert-1):
Follow my own advice from the last commit and use #'labels instead
of #'flet in core code.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 07 Sep 2011 21:21:36 +0100 |
| parents | 4654c01af32b |
| children | b039c0f018b8 |
| files | lisp/ChangeLog lisp/about.el lisp/cl-macs.el lisp/diagnose.el lisp/dialog.el lisp/faces.el lisp/glyphs.el lisp/help-macro.el lisp/info.el lisp/keymap.el lisp/lisp-mode.el lisp/loadhist.el lisp/minibuf.el lisp/mouse.el lisp/mule/chinese.el lisp/mule/mule-cmds.el lisp/mule/mule-x-init.el lisp/simple.el lisp/specifier.el lisp/test-harness.el lisp/x-compose.el |
| diffstat | 21 files changed, 738 insertions(+), 706 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/ChangeLog Wed Sep 07 21:21:36 2011 +0100 @@ -1,3 +1,37 @@ +2011-09-07 Aidan Kehoe <kehoea@parhasard.net> + + * simple.el (transpose-subr): + * specifier.el (let-specifier): + * specifier.el (derive-device-type-from-tag-set): + * test-harness.el (batch-test-emacs): + * x-compose.el (alias-colon-to-doublequote): + * mule/chinese.el (make-chinese-cns11643-charset): + * mule/mule-cmds.el (set-locale-for-language-environment): + * mule/mule-cmds.el (set-language-environment-coding-systems): + * mule/mule-x-init.el (x-use-halfwidth-roman-font): + * about.el (about-xemacs): + * about.el (about-hackers): + * diagnose.el (show-memory-usage): + * diagnose.el (show-object-memory-usage-stats): + * diagnose.el (show-mc-alloc-memory-usage): + * diagnose.el (show-gc-stats): + * dialog.el (make-dialog-box): + * faces.el: + * faces.el (Face-frob-property): + * faces.el (set-face-stipple): + * glyphs.el: + * glyphs.el (init-glyphs): Removed. + * help-macro.el (make-help-screen): + * info.el (Info-construct-menu): + * keymap.el (key-sequence-list-description): + * lisp-mode.el (construct-lisp-mode-menu): + * loadhist.el (unload-feature): + * minibuf.el (get-user-response): + * mouse.el (default-mouse-track-check-for-activation): + * mouse.el (mouse-track-insert-1): + Follow my own advice from the last commit and use #'labels instead + of #'flet in core code. + 2011-09-07 Aidan Kehoe <kehoea@parhasard.net> * bytecomp.el:
--- a/lisp/about.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/about.el Wed Sep 07 21:21:36 2011 +0100 @@ -467,21 +467,21 @@ XEmacs is the result of the time and effort of many people. The developers responsible for this release are:\n\n") - (flet ((setup-person (who) - (widget-insert "\t* ") - (let* ((entry (assq who xemacs-hackers)) - (name (cadr entry)) - (address (caddr entry))) - (widget-create 'link - :help-echo (concat "Find out more about " name) - :button-prefix "" - :button-suffix "" - :action 'about-maintainer - :tag name - :value who) - (widget-insert (format " <%s>\n" address))))) + (labels ((setup-person (who) + (widget-insert "\t* ") + (let* ((entry (assq who xemacs-hackers)) + (name (cadr entry)) + (address (caddr entry))) + (widget-create 'link + :help-echo (concat "Find out more about " name) + :button-prefix "" + :button-suffix "" + :action 'about-maintainer + :tag name + :value who) + (widget-insert (format " <%s>\n" address))))) ;; Setup persons responsible for this release. - (mapc 'setup-person about-current-release-maintainers) + (mapc #'setup-person about-current-release-maintainers) (widget-insert "\n\t* ") (widget-create 'link :help-echo "A legion of XEmacs hackers" :action 'about-hackers @@ -2009,14 +2009,12 @@ 'about-headline-face) "\n\n") (mapc 'about-show-linked-info about-once-and-future-hackers) - (flet ((print-short (name addr &optional shortinfo) - (widget-insert (concat (about-with-face name 'italic) - (about-tabs name) - "<")) - (about-mailto-link addr) - (widget-insert - (concat ">\n" - (if shortinfo (concat shortinfo "\n") ""))))) + (labels ((print-short (name addr &optional shortinfo) + (widget-insert (concat (about-with-face name 'italic) + (about-tabs name) "<")) + (about-mailto-link addr) + (widget-insert + (concat ">\n" (if shortinfo (concat shortinfo "\n") ""))))) (widget-insert "\n\ In addition to those just mentioned, the following people have spent a
--- a/lisp/cl-macs.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/cl-macs.el Wed Sep 07 21:21:36 2011 +0100 @@ -1763,7 +1763,8 @@ example, to pass it as a FUNCTION argument to `map'), quote its symbol name using `function'. -arguments: (((FUNCTION ARGLIST &body BODY) &rest FUNCTIONS) &body FORM)" +arguments: (((FUNCTION ARGLIST &body BODY) &rest FUNCTIONS) &body FORM) +" ;; XEmacs; the byte-compiler has a much better implementation of `labels' ;; in `byte-compile-initial-macro-environment' that is used in compiled ;; code.
--- a/lisp/diagnose.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/diagnose.el Wed Sep 07 21:21:36 2011 +0100 @@ -33,69 +33,68 @@ "Show statistics about memory usage of various sorts in XEmacs." (interactive) (garbage-collect) - (flet ((show-foo-stats (objtypename statname-plist cleanfun objlist - &optional objnamelen) - (let* ((hash (make-hash-table)) - (first t) - types origtypes fmt - (objnamelen (or objnamelen 25)) - (linelen objnamelen) - (totaltotal 0)) - (loop for obj in objlist do - (let ((total 0) - (stats (object-memory-usage obj))) - ;; Pop off the slice describing the object itself's - ;; memory - (while (and stats (not (eq t (pop stats))))) - ;; Pop off the slice describing the associated - ;; non-Lisp-Object memory from the allocation - ;; perspective, so we can get to the slice describing - ;; the memory grouped by type - (while (and stats (pop stats))) + (labels ((show-foo-stats (objtypename statname-plist cleanfun objlist + &optional objnamelen) + (let* ((hash (make-hash-table)) + (first t) + types origtypes fmt + (objnamelen (or objnamelen 25)) + (linelen objnamelen) + (totaltotal 0)) + (loop for obj in objlist do + (let ((total 0) + (stats (object-memory-usage obj))) + ;; Pop off the slice describing the object itself's + ;; memory + (while (and stats (not (eq t (pop stats))))) + ;; Pop off the slice describing the associated + ;; non-Lisp-Object memory from the allocation + ;; perspective, so we can get to the slice describing + ;; the memory grouped by type + (while (and stats (pop stats))) - (loop for (type . num) in (remq t stats) while type do - (if first (push type origtypes)) - (setq type (getf statname-plist type type)) - (puthash type (+ num (or (gethash type hash) 0)) hash) - (incf total num) - (if first (push type types))) - (incf totaltotal total) - (when first - (setq types (nreverse types)) - (setq origtypes (nreverse origtypes)) - (setq fmt (concat - (format "%%-%ds" objnamelen) - (mapconcat - #'(lambda (type) - (let ((fieldlen - (max 7 (+ 2 (length - (symbol-name type)))))) - (incf linelen fieldlen) - (format "%%%ds" fieldlen))) - types "") - (progn (incf linelen 9) "%9s\n"))) - (princ "\n") - (princ (apply 'format fmt objtypename - (append types (list 'total)))) - (princ (make-string linelen ?-)) - (princ "\n")) - (let ((objname (format "%s" (funcall cleanfun obj)))) - (princ (apply 'format fmt (substring objname 0 - (min (length objname) - (1- objnamelen))) - (nconc (mapcar #'(lambda (type) - (cdr (assq type stats))) - origtypes) - (list total))))) - (setq first nil))) - (princ "\n") - (princ (apply 'format fmt "total" - (nconc (mapcar #'(lambda (type) - (gethash type hash)) - types) - (list totaltotal)))) - totaltotal))) - + (loop for (type . num) in (remq t stats) while type do + (if first (push type origtypes)) + (setq type (getf statname-plist type type)) + (puthash type (+ num (or (gethash type hash) 0)) hash) + (incf total num) + (if first (push type types))) + (incf totaltotal total) + (when first + (setq types (nreverse types)) + (setq origtypes (nreverse origtypes)) + (setq fmt (concat + (format "%%-%ds" objnamelen) + (mapconcat + #'(lambda (type) + (let ((fieldlen + (max 7 (+ 2 (length + (symbol-name type)))))) + (incf linelen fieldlen) + (format "%%%ds" fieldlen))) + types "") + (progn (incf linelen 9) "%9s\n"))) + (princ "\n") + (princ (apply 'format fmt objtypename + (append types (list 'total)))) + (princ (make-string linelen ?-)) + (princ "\n")) + (let ((objname (format "%s" (funcall cleanfun obj)))) + (princ (apply 'format fmt (substring objname 0 + (min (length objname) + (1- objnamelen))) + (nconc (mapcar #'(lambda (type) + (cdr (assq type stats))) + origtypes) + (list total))))) + (setq first nil))) + (princ "\n") + (princ (apply 'format fmt "total" + (nconc (mapcar #'(lambda (type) + (gethash type hash)) + types) + (list totaltotal)))) + totaltotal))) (let ((grandtotal 0) (buffer "*memory usage*") begin) @@ -202,101 +201,102 @@ (fmt "%-28s%10s%10s%10s%10s%10s\n") (grandtotal 0) begin) - (flet ((show-stats (match-string) - (princ (format "%28s%10s%40s\n" "" "" - "--------------storage---------------")) - (princ (format fmt "object" "count" "object" "overhead" - "non-Lisp" "ancillary")) - (princ (make-string 78 ?-)) - (princ "\n") - (let ((total-use 0) - (total-non-lisp-use 0) - (total-use-overhead 0) - (total-use-with-overhead 0) - (total-count 0)) - (map-plist - #'(lambda (stat num) - (let ((symmatch - (and (string-match match-string (symbol-name stat)) - (match-string 1 (symbol-name stat))))) - (when (and symmatch - (or (< (length symmatch) 9) - (not (equal (substring symmatch -9) - "-non-lisp"))) - (or (< (length symmatch) 15) - (not (equal (substring symmatch -15) - "-lisp-ancillary")))) - (let* ((storage-use num) - (storage-use-overhead - (or (plist-get - plist - (intern (concat symmatch - "-storage-overhead"))) - 0)) - (storage-use-with-overhead - (or (plist-get - plist - (intern (concat - symmatch - "-storage-including-overhead"))) - (+ storage-use storage-use-overhead))) - (storage-use-overhead - (- storage-use-with-overhead storage-use)) - (non-lisp-storage - (or (plist-get - plist - (intern (concat symmatch - "-non-lisp-storage"))) - 0)) - (lisp-ancillary-storage - (or (plist-get - plist - (intern (concat symmatch - "-lisp-ancillary-storage"))) - 0)) - (storage-count - (or (loop for str in '("s-used" "es-used" "-used") - for val = (plist-get - plist - (intern - (concat symmatch str))) - if val - return val) - (plist-get - plist - (intern - (concat (substring symmatch 0 -1) - "ies-used"))) - ))) - (incf total-use storage-use) - (incf total-use-overhead storage-use-overhead) - (incf total-use-with-overhead storage-use-with-overhead) - (incf total-non-lisp-use non-lisp-storage) - (incf total-count (or storage-count 0)) - (and (> storage-use-with-overhead 0) - (princ (format fmt symmatch - (or storage-count "unknown") - storage-use - storage-use-overhead - non-lisp-storage - lisp-ancillary-storage))))))) - plist) - (princ "\n") - (princ (format fmt "total" - total-count total-use total-use-overhead - total-non-lisp-use "")) - (incf grandtotal total-use-with-overhead) - (incf grandtotal total-non-lisp-use) - (when-fboundp 'sort-numeric-fields - (sort-numeric-fields -4 - (save-excursion - (goto-char begin) - (forward-line 4) - (point)) - (save-excursion - (forward-line -2) - (point))))))) - (with-output-to-temp-buffer buffer + (labels + ((show-stats (match-string) + (princ (format "%28s%10s%40s\n" "" "" + "--------------storage---------------")) + (princ (format fmt "object" "count" "object" "overhead" + "non-Lisp" "ancillary")) + (princ (make-string 78 ?-)) + (princ "\n") + (let ((total-use 0) + (total-non-lisp-use 0) + (total-use-overhead 0) + (total-use-with-overhead 0) + (total-count 0)) + (map-plist + #'(lambda (stat num) + (let ((symmatch + (and (string-match match-string (symbol-name stat)) + (match-string 1 (symbol-name stat))))) + (when (and symmatch + (or (< (length symmatch) 9) + (not (equal (substring symmatch -9) + "-non-lisp"))) + (or (< (length symmatch) 15) + (not (equal (substring symmatch -15) + "-lisp-ancillary")))) + (let* ((storage-use num) + (storage-use-overhead + (or (plist-get + plist + (intern (concat symmatch + "-storage-overhead"))) + 0)) + (storage-use-with-overhead + (or (plist-get + plist + (intern (concat + symmatch + "-storage-including-overhead"))) + (+ storage-use storage-use-overhead))) + (storage-use-overhead + (- storage-use-with-overhead storage-use)) + (non-lisp-storage + (or (plist-get + plist + (intern (concat symmatch + "-non-lisp-storage"))) + 0)) + (lisp-ancillary-storage + (or (plist-get + plist + (intern (concat symmatch + "-lisp-ancillary-storage"))) + 0)) + (storage-count + (or (loop for str in '("s-used" "es-used" "-used") + for val = (plist-get + plist + (intern + (concat symmatch str))) + if val + return val) + (plist-get + plist + (intern + (concat (substring symmatch 0 -1) + "ies-used"))) + ))) + (incf total-use storage-use) + (incf total-use-overhead storage-use-overhead) + (incf total-use-with-overhead storage-use-with-overhead) + (incf total-non-lisp-use non-lisp-storage) + (incf total-count (or storage-count 0)) + (and (> storage-use-with-overhead 0) + (princ (format fmt symmatch + (or storage-count "unknown") + storage-use + storage-use-overhead + non-lisp-storage + lisp-ancillary-storage))))))) + plist) + (princ "\n") + (princ (format fmt "total" + total-count total-use total-use-overhead + total-non-lisp-use "")) + (incf grandtotal total-use-with-overhead) + (incf grandtotal total-non-lisp-use) + (when-fboundp 'sort-numeric-fields + (sort-numeric-fields -4 + (save-excursion + (goto-char begin) + (forward-line 4) + (point)) + (save-excursion + (forward-line -2) + (point))))))) + (with-output-to-temp-buffer buffer (save-excursion (set-buffer buffer) (setq begin (point)) @@ -319,114 +319,115 @@ (globals (fifth stats)) (mc-malloced-bytes (sixth stats))) (with-output-to-temp-buffer "*mc-alloc memory usage*" - (flet ((print-used-plhs (text plhs) - (let ((sum-n-pages 0) - (sum-used-n-cells 0) - (sum-used-space 0) - (sum-used-total 0) - (sum-total-n-cells 0) - (sum-total-space 0) - (sum-total-total 0) - (fmt "%7s%7s|%7s%9s%9s%4s|%7s%9s%9s%4s|%4s\n")) - (princ (format "%-14s|%-29s|%-29s|\n" - text - " currently in use" - " total available")) - (princ (format fmt "cell-sz" "#pages" - "#cells" "space" "total" "% " - "#cells" "space" "total" "% " "% ")) - (princ (make-string 79 ?-)) - (princ "\n") - (while plhs - (let* ((elem (car plhs)) - (cell-size (first elem)) - (n-pages (second elem)) - (used-n-cells (third elem)) - (used-space (fourth elem)) - (used-total (if (zerop cell-size) - (sixth elem) - (* cell-size used-n-cells))) - (used-eff (floor (if (not (zerop used-total)) - (* (/ (* used-space 1.0) - (* used-total 1.0)) + (labels + ((print-used-plhs (text plhs) + (let ((sum-n-pages 0) + (sum-used-n-cells 0) + (sum-used-space 0) + (sum-used-total 0) + (sum-total-n-cells 0) + (sum-total-space 0) + (sum-total-total 0) + (fmt "%7s%7s|%7s%9s%9s%4s|%7s%9s%9s%4s|%4s\n")) + (princ (format "%-14s|%-29s|%-29s|\n" + text + " currently in use" + " total available")) + (princ (format fmt "cell-sz" "#pages" + "#cells" "space" "total" "% " + "#cells" "space" "total" "% " "% ")) + (princ (make-string 79 ?-)) + (princ "\n") + (while plhs + (let* ((elem (car plhs)) + (cell-size (first elem)) + (n-pages (second elem)) + (used-n-cells (third elem)) + (used-space (fourth elem)) + (used-total (if (zerop cell-size) + (sixth elem) + (* cell-size used-n-cells))) + (used-eff (floor (if (not (zerop used-total)) + (* (/ (* used-space 1.0) + (* used-total 1.0)) + 100.0) + 0))) + (total-n-cells (fifth elem)) + (total-space (if (zerop cell-size) + used-space + (* cell-size total-n-cells))) + (total-total (sixth elem)) + (total-eff (floor (if (not (zerop total-total)) + (* (/ (* total-space 1.0) + (* total-total 1.0)) + 100.0) + 0))) + (eff (floor (if (not (zerop total-total)) + (* (/ (* used-space 1.0) + (* total-total 1.0)) + 100.0) + 0)))) + (princ (format fmt + cell-size n-pages used-n-cells used-space + used-total used-eff total-n-cells + total-space total-total total-eff eff)) + (incf sum-n-pages n-pages) + (incf sum-used-n-cells used-n-cells) + (incf sum-used-space used-space) + (incf sum-used-total used-total) + (incf sum-total-n-cells total-n-cells) + (incf sum-total-space total-space) + (incf sum-total-total total-total)) + (setq plhs (cdr plhs))) + (let ((avg-used-eff (floor (if (not (zerop sum-used-total)) + (* (/ (* sum-used-space 1.0) + (* sum-used-total 1.0)) + 100.0) + 0))) + (avg-total-eff (floor (if (not (zerop sum-total-total)) + (* (/ (* sum-total-space 1.0) + (* sum-total-total 1.0)) 100.0) 0))) - (total-n-cells (fifth elem)) - (total-space (if (zerop cell-size) - used-space - (* cell-size total-n-cells))) - (total-total (sixth elem)) - (total-eff (floor (if (not (zerop total-total)) - (* (/ (* total-space 1.0) - (* total-total 1.0)) - 100.0) - 0))) - (eff (floor (if (not (zerop total-total)) - (* (/ (* used-space 1.0) - (* total-total 1.0)) - 100.0) - 0)))) - (princ (format fmt - cell-size n-pages used-n-cells used-space - used-total used-eff total-n-cells - total-space total-total total-eff eff)) - (incf sum-n-pages n-pages) - (incf sum-used-n-cells used-n-cells) - (incf sum-used-space used-space) - (incf sum-used-total used-total) - (incf sum-total-n-cells total-n-cells) - (incf sum-total-space total-space) - (incf sum-total-total total-total)) - (setq plhs (cdr plhs))) - (let ((avg-used-eff (floor (if (not (zerop sum-used-total)) - (* (/ (* sum-used-space 1.0) - (* sum-used-total 1.0)) - 100.0) - 0))) - (avg-total-eff (floor (if (not (zerop sum-total-total)) - (* (/ (* sum-total-space 1.0) - (* sum-total-total 1.0)) - 100.0) - 0))) - (avg-eff (floor (if (not (zerop sum-total-total)) - (* (/ (* sum-used-space 1.0) - (* sum-total-total 1.0)) - 100.0) - 0)))) - (princ (format fmt "sum " sum-n-pages sum-used-n-cells - sum-used-space sum-used-total avg-used-eff - sum-total-n-cells sum-total-space - sum-total-total avg-total-eff avg-eff)) - (princ "\n")))) + (avg-eff (floor (if (not (zerop sum-total-total)) + (* (/ (* sum-used-space 1.0) + (* sum-total-total 1.0)) + 100.0) + 0)))) + (princ (format fmt "sum " sum-n-pages sum-used-n-cells + sum-used-space sum-used-total avg-used-eff + sum-total-n-cells sum-total-space + sum-total-total avg-total-eff avg-eff)) + (princ "\n")))) - (print-free-plhs (text plhs) - (let ((sum-n-pages 0) - (sum-n-sects 0) - (sum-space 0) - (sum-total 0) - (fmt "%6s%10s |%7s%10s\n")) - (princ (format "%s\n" text)) - (princ (format fmt "#pages" "space" "#sects" "total")) - (princ (make-string 35 ?-)) - (princ "\n") - (while plhs - (let* ((elem (car plhs)) - (n-pages (first elem)) - (n-sects (second elem)) - (space (* n-pages page-size)) - (total (* n-sects space))) - (princ (format fmt n-pages space n-sects total)) - (incf sum-n-pages n-pages) - (incf sum-n-sects n-sects) - (incf sum-space space) - (incf sum-total total)) - (setq plhs (cdr plhs))) - (princ (make-string 35 ?=)) - (princ "\n") - (princ (format fmt sum-n-pages sum-space - sum-n-sects sum-total)) - (princ "\n")))) + (print-free-plhs (text plhs) + (let ((sum-n-pages 0) + (sum-n-sects 0) + (sum-space 0) + (sum-total 0) + (fmt "%6s%10s |%7s%10s\n")) + (princ (format "%s\n" text)) + (princ (format fmt "#pages" "space" "#sects" "total")) + (princ (make-string 35 ?-)) + (princ "\n") + (while plhs + (let* ((elem (car plhs)) + (n-pages (first elem)) + (n-sects (second elem)) + (space (* n-pages page-size)) + (total (* n-sects space))) + (princ (format fmt n-pages space n-sects total)) + (incf sum-n-pages n-pages) + (incf sum-n-sects n-sects) + (incf sum-space space) + (incf sum-total total)) + (setq plhs (cdr plhs))) + (princ (make-string 35 ?=)) + (princ "\n") + (princ (format fmt sum-n-pages sum-space + sum-n-sects sum-total)) + (princ "\n")))) (princ (format "%-12s%10s\n\n" "PAGE_SIZE" page-size)) @@ -467,19 +468,19 @@ (let ((buffer "*garbage collection statistics*") (plist (gc-stats)) (fmt "%-9s %16s %12s %12s %12s %12s\n")) - (flet ((plist-get-stat (category field) - (let ((stat (plist-get plist - (intern (concat category field))))) - (if stat - (format "%.0f" stat) - "-"))) - (show-stats (category) - (princ (format fmt category - (plist-get-stat category "-total") - (plist-get-stat category "-in-last-gc") - (plist-get-stat category "-in-this-gc") - (plist-get-stat category "-in-last-cycle") - (plist-get-stat category "-in-this-cycle"))))) + (labels + ((plist-get-stat (category field) + (let ((stat (plist-get plist (intern (concat category field))))) + (if stat + (format "%.0f" stat) + "-"))) + (show-stats (category) + (princ (format fmt category + (plist-get-stat category "-total") + (plist-get-stat category "-in-last-gc") + (plist-get-stat category "-in-this-gc") + (plist-get-stat category "-in-last-cycle") + (plist-get-stat category "-in-this-cycle"))))) (with-output-to-temp-buffer buffer (save-excursion (set-buffer buffer)
--- a/lisp/dialog.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/dialog.el Wed Sep 07 21:21:36 2011 +0100 @@ -504,158 +504,159 @@ `cancel' value if either the ESC key is pressed or the Cancel button is selected. If the message box has no Cancel button, pressing ESC has no effect." - (flet ((dialog-box-modal-loop (thunk) - (let* ((frames (frame-list)) - (result - ;; ok, this is extremely tricky. normally a modal - ;; dialog will pop itself down using (dialog-box-finish) - ;; or (dialog-box-cancel), which throws back to this - ;; catch. but question dialog boxes pop down themselves - ;; regardless, so a badly written question dialog box - ;; that does not use (dialog-box-finish) could seriously - ;; wedge us. furthermore, we disable all other frames - ;; in order to implement modality; we need to restore - ;; them before the dialog box is destroyed, because - ;; otherwise windows at least will notice that no top- - ;; level window can have the focus and will shift the - ;; focus to a different app, raising it and obscuring us. - ;; so we create `delete-dialog-box-hook', which is - ;; called right *before* the dialog box gets destroyed. - ;; here, we put a hook on it, and when it's our dialog - ;; box and not someone else's that's being destroyed, - ;; we reenable all the frames and remove the hook. - ;; BUT ... we still have to deal with exiting the - ;; modal loop in case it doesn't happen before us. - ;; we can't do this until after the callbacks for this - ;; dialog box get executed, and that doesn't happen until - ;; after the dialog box is destroyed. so to keep things - ;; synchronous, we enqueue an eval event, which goes into - ;; the same queue as the misc-user events encapsulating - ;; the dialog callbacks and will go after it (because - ;; destroying the dialog box happens after processing - ;; its selection). if the dialog boxes are written - ;; properly, we don't see this eval event, because we've - ;; already exited our modal loop. (Thus, we make sure the - ;; function given in this eval event is actually defined - ;; and does nothing.) If we do see it, though, we know - ;; that we encountered a badly written dialog box and - ;; need to exit now. Currently we just return nil, but - ;; maybe we should signal an error or issue a warning. - (catch 'internal-dialog-box-finish - (let ((id (eval thunk)) - (sym (gensym))) - (fset sym - `(lambda (did) - (when (eq ',id did) - (mapc 'enable-frame ',frames) - (enqueue-eval-event - 'internal-make-dialog-box-exit did) - (remove-hook 'delete-dialog-box-hook - ',sym)))) - (if (framep id) - (add-hook 'delete-frame-hook sym) - (add-hook 'delete-dialog-box-hook sym)) - (mapc 'disable-frame frames) - (block nil - (while t - (let ((event (next-event))) - (if (and (eval-event-p event) - (eq (event-function event) - 'internal-make-dialog-box-exit) - (eq (event-object event) id)) - (return '(nil)) - (dispatch-event event))))))))) - (if (listp result) - (car result) - (signal 'quit nil))))) + (labels + ((dialog-box-modal-loop (thunk) + (let* ((frames (frame-list)) + (result + ;; ok, this is extremely tricky. normally a modal dialog + ;; will pop itself down using (dialog-box-finish) or + ;; (dialog-box-cancel), which throws back to this catch. + ;; but question dialog boxes pop down themselves + ;; regardless, so a badly written question dialog box that + ;; does not use (dialog-box-finish) could seriously wedge + ;; us. furthermore, we disable all other frames in order + ;; to implement modality; we need to restore them before + ;; the dialog box is destroyed, because otherwise windows + ;; at least will notice that no top- level window can have + ;; the focus and will shift the focus to a different app, + ;; raising it and obscuring us. so we create + ;; `delete-dialog-box-hook', which is called right *before* + ;; the dialog box gets destroyed. here, we put a hook on + ;; it, and when it's our dialog box and not someone else's + ;; that's being destroyed, we reenable all the frames and + ;; remove the hook. BUT ... we still have to deal with + ;; exiting the modal loop in case it doesn't happen before + ;; us. we can't do this until after the callbacks for this + ;; dialog box get executed, and that doesn't happen until + ;; after the dialog box is destroyed. so to keep things + ;; synchronous, we enqueue an eval event, which goes into + ;; the same queue as the misc-user events encapsulating the + ;; dialog callbacks and will go after it (because + ;; destroying the dialog box happens after processing its + ;; selection). if the dialog boxes are written properly, + ;; we don't see this eval event, because we've already + ;; exited our modal loop. (Thus, we make sure the function + ;; given in this eval event is actually defined and does + ;; nothing.) If we do see it, though, we know that we + ;; encountered a badly written dialog box and need to exit + ;; now. Currently we just return nil, but maybe we should + ;; signal an error or issue a warning. + (catch 'internal-dialog-box-finish + (let ((id (eval thunk)) + (sym (gensym))) + (fset sym + `(lambda (did) + (when (eq ',id did) + (mapc 'enable-frame ',frames) + (enqueue-eval-event + 'internal-make-dialog-box-exit did) + (remove-hook 'delete-dialog-box-hook + ',sym)))) + (if (framep id) + (add-hook 'delete-frame-hook sym) + (add-hook 'delete-dialog-box-hook sym)) + (mapc 'disable-frame frames) + (block nil + (while t + (let ((event (next-event))) + (if (and (eval-event-p event) + (eq (event-function event) + 'internal-make-dialog-box-exit) + (eq (event-object event) id)) + (return '(nil)) + (dispatch-event event))))))))) + (if (listp result) + (car result) + (signal 'quit nil))))) (case type (general - (flet ((create-dialog-box-frame () - (let* ((ftop (frame-property parent 'top)) - (fleft (frame-property parent 'left)) - (fwidth (frame-pixel-width parent)) - (fheight (frame-pixel-height parent)) - (fonth (font-height (face-font 'default))) - (fontw (font-width (face-font 'default))) - (properties (append properties - dialog-frame-plist)) - (dfheight (plist-get properties 'height)) - (dfwidth (plist-get properties 'width)) - (unmapped (plist-get properties - 'initially-unmapped)) - (gutter-spec spec) - (name (or (plist-get properties 'name) "XEmacs")) - (frame nil)) - (plist-remprop properties 'initially-unmapped) - ;; allow the user to just provide a glyph - (or (glyphp spec) (setq spec (make-glyph spec))) - (setq gutter-spec (copy-sequence "\n")) - (set-extent-begin-glyph (make-extent 0 1 gutter-spec) - spec) - ;; under FVWM at least, if I don't specify the - ;; initial position, it ends up always at (0, 0). - ;; xwininfo doesn't tell me that there are any - ;; program-specified position hints, so it must be - ;; an FVWM bug. So just be smashing and position in - ;; the center of the selected frame. - (setq frame - (make-frame - (append properties - `(popup - ,parent initially-unmapped t - menubar-visible-p nil - has-modeline-p nil - default-toolbar-visible-p nil - top-gutter-visible-p t - top-gutter-height ,(* dfheight fonth) - top-gutter ,gutter-spec - minibuffer none - name ,name - modeline-shadow-thickness 0 - vertical-scrollbar-visible-p nil - horizontal-scrollbar-visible-p nil - unsplittable t - internal-border-width 8 - left ,(+ fleft (- (/ fwidth 2) - (/ (* dfwidth - fontw) - 2))) - top ,(+ ftop (- (/ fheight 2) - (/ (* dfheight - fonth) - 2))))))) - (set-face-foreground 'modeline [default foreground] frame) - (set-face-background 'modeline [default background] frame) - ;; resize before mapping - (when autosize - (set-frame-displayable-pixel-size - frame - (image-instance-width - (glyph-image-instance spec - (frame-selected-window frame))) - (image-instance-height - (glyph-image-instance spec - (frame-selected-window frame))))) - ;; somehow, even though the resizing is supposed - ;; to be while the frame is not visible, a - ;; visible resize is perceptible - (unless unmapped (make-frame-visible frame)) - (let ((newbuf (generate-new-buffer " *dialog box*"))) - (set-buffer-dedicated-frame newbuf frame) - (set-frame-property frame 'dialog-box-buffer newbuf) - (set-window-buffer (frame-root-window frame) newbuf) - (with-current-buffer newbuf - (set (make-local-variable 'frame-title-format) - title) - (add-local-hook 'delete-frame-hook - #'(lambda (frame) - (kill-buffer - (frame-property - frame - 'dialog-box-buffer)))))) - frame))) + (labels + ((create-dialog-box-frame () + (let* ((ftop (frame-property parent 'top)) + (fleft (frame-property parent 'left)) + (fwidth (frame-pixel-width parent)) + (fheight (frame-pixel-height parent)) + (fonth (font-height (face-font 'default))) + (fontw (font-width (face-font 'default))) + (properties (append properties + dialog-frame-plist)) + (dfheight (plist-get properties 'height)) + (dfwidth (plist-get properties 'width)) + (unmapped (plist-get properties + 'initially-unmapped)) + (gutter-spec spec) + (name (or (plist-get properties 'name) "XEmacs")) + (frame nil)) + (plist-remprop properties 'initially-unmapped) + ;; allow the user to just provide a glyph + (or (glyphp spec) (setq spec (make-glyph spec))) + (setq gutter-spec (copy-sequence "\n")) + (set-extent-begin-glyph (make-extent 0 1 gutter-spec) + spec) + ;; under FVWM at least, if I don't specify the + ;; initial position, it ends up always at (0, 0). + ;; xwininfo doesn't tell me that there are any + ;; program-specified position hints, so it must be + ;; an FVWM bug. So just be smashing and position in + ;; the center of the selected frame. + (setq frame + (make-frame + (append properties + `(popup + ,parent initially-unmapped t + menubar-visible-p nil + has-modeline-p nil + default-toolbar-visible-p nil + top-gutter-visible-p t + top-gutter-height ,(* dfheight fonth) + top-gutter ,gutter-spec + minibuffer none + name ,name + modeline-shadow-thickness 0 + vertical-scrollbar-visible-p nil + horizontal-scrollbar-visible-p nil + unsplittable t + internal-border-width 8 + left ,(+ fleft (- (/ fwidth 2) + (/ (* dfwidth + fontw) + 2))) + top ,(+ ftop (- (/ fheight 2) + (/ (* dfheight + fonth) + 2))))))) + (set-face-foreground 'modeline [default foreground] frame) + (set-face-background 'modeline [default background] frame) + ;; resize before mapping + (when autosize + (set-frame-displayable-pixel-size + frame + (image-instance-width + (glyph-image-instance spec + (frame-selected-window frame))) + (image-instance-height + (glyph-image-instance spec + (frame-selected-window frame))))) + ;; somehow, even though the resizing is supposed + ;; to be while the frame is not visible, a + ;; visible resize is perceptible + (unless unmapped (make-frame-visible frame)) + (let ((newbuf (generate-new-buffer " *dialog box*"))) + (set-buffer-dedicated-frame newbuf frame) + (set-frame-property frame 'dialog-box-buffer newbuf) + (set-window-buffer (frame-root-window frame) newbuf) + (with-current-buffer newbuf + (set (make-local-variable 'frame-title-format) + title) + (add-local-hook 'delete-frame-hook + #'(lambda (frame) + (kill-buffer + (frame-property + frame + 'dialog-box-buffer)))))) + frame))) (if modal - (dialog-box-modal-loop '(create-dialog-box-frame)) + (dialog-box-modal-loop (list #'create-dialog-box-frame)) (create-dialog-box-frame)))) (question (remf rest :modal)
--- a/lisp/faces.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/faces.el Wed Sep 07 21:21:36 2011 +0100 @@ -1016,7 +1016,7 @@ ;; clearly added after-the-fact, don't deserve to live. DOCUMENT ;; THIS SHIT! - (flet + (labels ( ;; non-nil if either instantiator non-nil, or nil instantiators allowed. @@ -1139,7 +1139,7 @@ (cons prop 'tty) tag-set exact-p))) - ;; end of flets + ;; end of labels ) ;; the function itself @@ -2049,11 +2049,11 @@ (t nil)))) ;; We're signaling a continuable error; let's make sure the ;; function `stipple-pixmap-p' at least exists. - (flet ((stipple-pixmap-p (pixmap) - (or (stringp pixmap) - (and (listp pixmap) (eql (length pixmap) 3))))) + (labels ((stipple-pixmap-p (pixmap) + (or (stringp pixmap) + (and (listp pixmap) (eql (length pixmap) 3))))) (setq pixmap (signal 'wrong-type-argument - (list 'stipple-pixmap-p pixmap))))) + (list #'stipple-pixmap-p pixmap))))) (check-type frame (or null frame)) (set-face-background-pixmap face instantiator frame)))
--- a/lisp/glyphs.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/glyphs.el Wed Sep 07 21:21:36 2011 +0100 @@ -1135,108 +1135,105 @@ (defalias 'subwindow-height 'image-instance-height) ;;;;;;;;;; initialization -(defun init-glyphs () - ;; initialize default image types - (if (featurep 'x) - (set-console-type-image-conversion-list 'x - `(,@(if (featurep 'xpm) '(("\\.xpm\\'" [xpm :file nil] 2))) - ("\\.xbm\\'" [xbm :file nil] 2) - ("/bitmaps/" [xbm :file nil] 2) - ,@(if (featurep 'xpm) '(("\\`/\\* XPM \\*/" [xpm :data nil] 2))) - ,@(if (featurep 'xface) '(("\\`X-Face:" [xface :data nil] 2))) - ,@(if (featurep 'gif) '(("\\.gif\\'" [gif :file nil] 2) - ("\\`GIF8[79]" [gif :data nil] 2))) - ,@(if (featurep 'jpeg) '(("\\.jpe?g\\'" [jpeg :file nil] 2))) - ;; all of the JFIF-format JPEG's that I've seen begin with - ;; the following. I have no idea if this is standard. - ,@(if (featurep 'jpeg) '(("\\`\377\330\377\340\000\020JFIF" - [jpeg :data nil] 2))) - ,@(if (featurep 'png) '(("\\.png\\'" [png :file nil] 2))) - ,@(if (featurep 'png) '(("\\`\211PNG" [png :data nil] 2))) - ("" [string :data nil] 2) - ("" [nothing])))) - ;; #### this should really be formatted-string, not string but we - ;; don't have it implemented yet - (if (featurep 'tty) - (progn - (set-console-type-image-conversion-list - 'tty - '(("\\.xpm\\'" [string :data nil] 2) - ("\\.xbm\\'" [string :data nil] 2) - ("/bitmaps/" [string :data nil] 2) - ;; #define could also mean a bitmap as well as a version 1 XPM. Who - ;; cares. - ("^#define" [string :data "[xpm]"]) - ("\\`/\\* XPM \\*/" [string :data "[xpm]"]) - ("\\`X-Face:" [string :data "[xface]"]) - ("\\.gif\\'" [string :data nil] 2) - ("\\`GIF8[79]" [string :data "[gif]"]) - ("\\.jpe?g\\'" [string :data nil] 2) - ("\\`\377\330\340\000\020JFIF" [string :data "[jpeg]"]) - ;; all of the JFIF-format JPEG's that I've seen begin with - ;; the following. I have no idea if this is standard. - ("\\`\377\330\377\340\000\020JFIF" [string :data "[jpeg]"]) - ("\\.png\\'" [string :data nil] 2) - ("\\`\211PNG" [string :data "[png]"]) - ("" [string :data nil] 2) - ;; this last one is here for pointers and icons and such -- - ;; strings are not allowed so they will be ignored. - ("" [nothing]))) - - ;; finish initializing truncation glyph -- created internally - ;; because it has a built-in bitmap - (set-glyph-image truncation-glyph "$" 'global 'tty) +(labels + ((init-glyphs () + "Initialize default image types at dump time." + (if (featurep 'x) + (set-console-type-image-conversion-list + 'x `(,@(if (featurep 'xpm) '(("\\.xpm\\'" [xpm :file nil] 2))) + ("\\.xbm\\'" [xbm :file nil] 2) + ("/bitmaps/" [xbm :file nil] 2) + ,@(if (featurep 'xpm) + '(("\\`/\\* XPM \\*/" [xpm :data nil] 2))) + ,@(if (featurep 'xface) + '(("\\`X-Face:" [xface :data nil] 2))) + ,@(if (featurep 'gif) '(("\\.gif\\'" [gif :file nil] 2) + ("\\`GIF8[79]" [gif :data nil] 2))) + ,@(if (featurep 'jpeg) '(("\\.jpe?g\\'" [jpeg :file nil] 2))) + ;; all of the JFIF-format JPEG's that I've seen begin with + ;; the following. I have no idea if this is standard. + ,@(if (featurep 'jpeg) '(("\\`\377\330\377\340\000\020JFIF" + [jpeg :data nil] 2))) + ,@(if (featurep 'png) '(("\\.png\\'" [png :file nil] 2))) + ,@(if (featurep 'png) '(("\\`\211PNG" [png :data nil] 2))) + ("" [string :data nil] 2) + ("" [nothing])))) + ;; #### this should really be formatted-string, not string but we + ;; don't have it implemented yet + (if (featurep 'tty) + (progn + (set-console-type-image-conversion-list + 'tty + '(("\\.xpm\\'" [string :data nil] 2) + ("\\.xbm\\'" [string :data nil] 2) + ("/bitmaps/" [string :data nil] 2) + ;; #define could also mean a bitmap as well as a version 1 + ;; XPM. Who cares. + ("^#define" [string :data "[xpm]"]) + ("\\`/\\* XPM \\*/" [string :data "[xpm]"]) + ("\\`X-Face:" [string :data "[xface]"]) + ("\\.gif\\'" [string :data nil] 2) + ("\\`GIF8[79]" [string :data "[gif]"]) + ("\\.jpe?g\\'" [string :data nil] 2) + ("\\`\377\330\340\000\020JFIF" [string :data "[jpeg]"]) + ;; all of the JFIF-format JPEG's that I've seen begin with + ;; the following. I have no idea if this is standard. + ("\\`\377\330\377\340\000\020JFIF" [string :data "[jpeg]"]) + ("\\.png\\'" [string :data nil] 2) + ("\\`\211PNG" [string :data "[png]"]) + ("" [string :data nil] 2) + ;; this last one is here for pointers and icons and such -- + ;; strings are not allowed so they will be ignored. + ("" [nothing]))) - ;; finish initializing continuation glyph -- created internally - ;; because it has a built-in bitmap - (set-glyph-image continuation-glyph "\\" 'global 'tty) + ;; finish initializing truncation glyph -- created internally + ;; because it has a built-in bitmap + (set-glyph-image truncation-glyph "$" 'global 'tty) - ;; finish initializing hscroll glyph -- created internally - ;; because it has a built-in bitmap - (set-glyph-image hscroll-glyph "$" 'global 'tty))) - - ;; For streams, we don't want images at all -- dvl - (set-console-type-image-conversion-list 'stream '(("" [nothing]))) + ;; finish initializing continuation glyph -- created internally + ;; because it has a built-in bitmap + (set-glyph-image continuation-glyph "\\" 'global 'tty) - - (set-glyph-image octal-escape-glyph "\\") - (set-glyph-image control-arrow-glyph "^") - (set-glyph-image invisible-text-glyph " ...") - ;; (set-glyph-image hscroll-glyph "$") + ;; finish initializing hscroll glyph -- created internally + ;; because it has a built-in bitmap + (set-glyph-image hscroll-glyph "$" 'global 'tty))) - (let ((face (make-face 'border-glyph - "Truncation and continuation glyphs face"))) - (set-glyph-face continuation-glyph face) - (set-glyph-face truncation-glyph face) - (set-glyph-face hscroll-glyph face)) + ;; For streams, we don't want images at all -- dvl + (set-console-type-image-conversion-list 'stream '(("" [nothing]))) + + (set-glyph-image octal-escape-glyph "\\") + (set-glyph-image control-arrow-glyph "^") + (set-glyph-image invisible-text-glyph " ...") + ;; (set-glyph-image hscroll-glyph "$") - ;; finish initializing xemacs logo -- created internally because it - ;; has a built-in bitmap - (if (featurep 'xpm) - (set-glyph-image xemacs-logo - (concat "../etc/" - (if emacs-beta-version - "xemacs-beta.xpm" - "xemacs.xpm")) - 'global 'x)) - (cond ((featurep 'xpm) - (set-glyph-image frame-icon-glyph - (concat "../etc/" "xemacs-icon.xpm") - 'global 'x)) - ((featurep 'x) - (set-glyph-image frame-icon-glyph - (concat "../etc/" "xemacs-icon2.xbm") - 'global 'x))) + (let ((face (make-face 'border-glyph + "Truncation and continuation glyphs face"))) + (set-glyph-face continuation-glyph face) + (set-glyph-face truncation-glyph face) + (set-glyph-face hscroll-glyph face)) - (if (featurep 'tty) - (set-glyph-image xemacs-logo - "XEmacs <insert spiffy graphic logo here>" - 'global 'tty)) -) + ;; finish initializing xemacs logo -- created internally because it + ;; has a built-in bitmap + (if (featurep 'xpm) + (set-glyph-image xemacs-logo + (concat "../etc/" + (if emacs-beta-version + "xemacs-beta.xpm" + "xemacs.xpm")) + 'global 'x)) + (cond ((featurep 'xpm) + (set-glyph-image frame-icon-glyph + (concat "../etc/" "xemacs-icon.xpm") + 'global 'x)) + ((featurep 'x) + (set-glyph-image frame-icon-glyph + (concat "../etc/" "xemacs-icon2.xbm") + 'global 'x))) -(init-glyphs) - -(unintern 'init-glyphs) ;; This was dump time thing, no need to keep the - ;; function around. + (if (featurep 'tty) + (set-glyph-image xemacs-logo + "XEmacs <insert spiffy graphic logo here>" + 'global 'tty)))) + (init-glyphs)) ;;; glyphs.el ends here.
--- a/lisp/help-macro.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/help-macro.el Wed Sep 07 21:21:36 2011 +0100 @@ -86,24 +86,25 @@ `(defun ,fname () ,(eval help-text) (interactive) - (flet ((help-read-key (prompt) - ;; This is in `flet' to avoid problems with autoloading. - ;; #### The function is ill-conceived -- there should be - ;; a way to do it without all the hassle! - (let (events) - (while (not (key-press-event-p - (aref (setq events (read-key-sequence prompt)) 0))) - ;; Mouse clicks are not part of the help feature, so - ;; reexecute them in the standard environment. - (mapc 'dispatch-event events)) - (let ((key (nconc (event-modifiers (aref events 0)) - (list (event-key (aref events 0)))))) - ;; Make the HELP key translate to C-h. - (when (lookup-key function-key-map key) - (setq key (lookup-key function-key-map key))) - (if (eq (length key) 1) - (car key) - key))))) + (labels + ((help-read-key (prompt) + ;; This is in `labels' to avoid problems with autoloading. + ;; #### The function is ill-conceived -- there should be + ;; a way to do it without all the hassle! + (let (events) + (while (not (key-press-event-p + (aref (setq events (read-key-sequence prompt)) 0))) + ;; Mouse clicks are not part of the help feature, so + ;; reexecute them in the standard environment. + (mapc 'dispatch-event events)) + (let ((key (nconc (event-modifiers (aref events 0)) + (list (event-key (aref events 0)))))) + ;; Make the HELP key translate to C-h. + (when (lookup-key function-key-map key) + (setq key (lookup-key function-key-map key))) + (if (eq (length key) 1) + (car key) + key))))) (let ((line-prompt (substitute-command-keys ,(eval help-line)))) (when three-step-help
--- a/lisp/info.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/info.el Wed Sep 07 21:21:36 2011 +0100 @@ -3232,14 +3232,14 @@ up-p prev-p next-p menu xrefs subnodes in) (save-excursion ;; `one-space' fixes "Notes:" xrefs that are split across lines. - (flet + (labels ((one-space (text) - (let (i) - (while (setq i (string-match "[ \n\t]+" text i)) - (setq text (concat (substring text 0 i) " " - (substring text (match-end 0)))) - (setq i (1+ i))) - text))) + (let (i) + (while (setq i (string-match "[ \n\t]+" text i)) + (setq text (concat (substring text 0 i) " " + (substring text (match-end 0)))) + (setq i (1+ i))) + text))) (goto-char (point-min)) (if (looking-at ".*\\bNext:") (setq next-p t)) (if (looking-at ".*\\bPrev:") (setq prev-p t))
--- a/lisp/keymap.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/keymap.el Wed Sep 07 21:21:36 2011 +0100 @@ -417,8 +417,8 @@ (vconcat keys)) (t (vector keys))))) - (flet ((event-to-list (ev) - (append (event-modifiers ev) (list (event-key ev))))) + (labels ((event-to-list (ev) + (append (event-modifiers ev) (list (event-key ev))))) (mapvector #'(lambda (key) (let* ((full-key
--- a/lisp/lisp-mode.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/lisp-mode.el Wed Sep 07 21:21:36 2011 +0100 @@ -43,8 +43,8 @@ (defvar lisp-mode-abbrev-table nil) (defun construct-lisp-mode-menu (popup-p emacs-lisp-p) - (flet ((popup-wrap (form) - (if popup-p `(menu-call-at-event ',form) form))) + (labels ((popup-wrap (form) + (if popup-p `(menu-call-at-event ',form) form))) `(,@(if emacs-lisp-p `(["%_Byte-Compile This File" ,(popup-wrap 'emacs-lisp-byte-compile)]
--- a/lisp/loadhist.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/loadhist.el Wed Sep 07 21:21:36 2011 +0100 @@ -175,29 +175,29 @@ (let* ((flist (feature-symbols feature)) (file (car flist)) (unloading-module nil)) - (flet ((reset-aload (x) - (let ((aload (get x 'autoload))) - (if aload (fset x (cons 'autoload aload)))))) - (mapc - #'(lambda (x) - (cond ((stringp x) nil) - ((consp x) - ;; Remove any feature names that this file provided. - (if (eq (car x) 'provide) - (setq features (delq (cdr x) features)) - (if (eq (car x) 'module) - (setq unloading-module t)))) - ((and (boundp x) - (fboundp x)) - (makunbound x) - (fmakunbound x) - (reset-aload x)) - ((boundp x) - (makunbound x)) - ((fboundp x) - (fmakunbound x) - (reset-aload x)))) - (cdr flist))) + (labels ((reset-aload (x) + (let ((aload (get x 'autoload))) + (if aload (fset x (cons 'autoload aload)))))) + (mapc + #'(lambda (x) + (cond ((stringp x) nil) + ((consp x) + ;; Remove any feature names that this file provided. + (if (eq (car x) 'provide) + (setq features (delq (cdr x) features)) + (if (eq (car x) 'module) + (setq unloading-module t)))) + ((and (boundp x) + (fboundp x)) + (makunbound x) + (fmakunbound x) + (reset-aload x)) + ((boundp x) + (makunbound x)) + ((fboundp x) + (fmakunbound x) + (reset-aload x)))) + (cdr flist))) ;; Delete the load-history element for this file. (let ((elt (assoc file load-history))) (setq load-history (delq elt load-history)))
--- a/lisp/minibuf.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/minibuf.el Wed Sep 07 21:21:36 2011 +0100 @@ -2284,9 +2284,9 @@ (let* ((answers (remove-if-not #'consp answers)) (possible (gettext - (flet ((car-to-string-if (x) - (setq x (car x)) - (if (stringp x) x (char-to-string x)))) + (labels ((car-to-string-if (x) + (setq x (car x)) + (if (stringp x) x (char-to-string x)))) (concat (mapconcat #'car-to-string-if (butlast answers) ", ") " or " (car-to-string-if (car (last answers)))))))
--- a/lisp/mouse.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/mouse.el Wed Sep 07 21:21:36 2011 +0100 @@ -1246,11 +1246,11 @@ ;; `conservative-activate-function'. (defun default-mouse-track-check-for-activation (event click-count count-list button-list) - (flet ((do-activate (event property) - (let ((ex (extent-at-event event property))) - (when ex - (funcall (extent-property ex property) event ex) - t)))) + (labels ((do-activate (event property) + (let ((ex (extent-at-event event property))) + (when ex + (funcall (extent-property ex property) event ex) + t)))) (or (and (some #'(lambda (count button) (and (= click-count count) @@ -1477,23 +1477,23 @@ (let ((default-mouse-track-type-list (if line-p '(line) default-mouse-track-type-list)) s selreg) - (flet ((Mouse-track-insert-drag-up-hook (event count) - (setq selreg - (default-mouse-track-return-dragged-selection event)) - t) - (Mouse-track-insert-click-hook (event count) - (default-mouse-track-drag-hook event count nil) - (setq selreg - (default-mouse-track-return-dragged-selection event)) - t)) + (labels ((Mouse-track-insert-drag-up-hook (event count) + (setq selreg + (default-mouse-track-return-dragged-selection event)) + t) + (Mouse-track-insert-click-hook (event count) + (default-mouse-track-drag-hook event count nil) + (setq selreg + (default-mouse-track-return-dragged-selection event)) + t)) (save-excursion (save-window-excursion (mouse-track event - '(mouse-track-drag-up-hook - Mouse-track-insert-drag-up-hook - mouse-track-click-hook - Mouse-track-insert-click-hook)) + (list 'mouse-track-drag-up-hook + #'Mouse-track-insert-drag-up-hook + 'mouse-track-click-hook + #'Mouse-track-insert-click-hook)) (if (consp selreg) (let ((pair selreg)) (setq s (prog1
--- a/lisp/mule/chinese.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/mule/chinese.el Wed Sep 07 21:21:36 2011 +0100 @@ -41,7 +41,7 @@ ;; that appear once in some ancient manuscript and whose meaning ;; is unknown. -(flet +(labels ((make-chinese-cns11643-charset (name plane final) (make-charset
--- a/lisp/mule/mule-cmds.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/mule/mule-cmds.el Wed Sep 07 21:21:36 2011 +0100 @@ -835,9 +835,9 @@ (if (symbolp language-name) (setq language-name (symbol-name language-name))) (let ((doc (get-language-info language-name 'documentation))) - (flet ((princ-list (&rest args) - (while args (princ (car args)) (setq args (cdr args))) - (princ "\n"))) + (labels ((princ-list (&rest args) + (while args (princ (car args)) (setq args (cdr args))) + (princ "\n"))) (with-output-to-temp-buffer "*Help*" (princ-list language-name " language environment" "\n") (if (stringp doc) @@ -1228,38 +1228,39 @@ setting it using `set-current-locale' and maybe also `mswindows-set-current-locale'. Also sets the LANG environment variable. Returns non-nil if successfully set the locale(s)." - (flet ((mswindows-get-and-set-locale-from-langenv (langenv) - ;; find the mswindows locale for the langenv, make it current, - ;; and return it. first we check the langenv-to-locale table - ;; ... - (let ((ms-locale - (gethash langenv mswindows-langenv-to-locale-table))) - (if ms-locale (progn - (declare-fboundp (mswindows-set-current-locale - ms-locale)) - ms-locale) - ;; ... if not, see if the langenv specifies any locale(s). - ;; if not, construct one from the langenv name. - (let* ((mslocs (get-language-info langenv 'mswindows-locale)) - (mslocs (or mslocs (cons (upcase langenv) "DEFAULT"))) - (mslocs (if (and (consp mslocs) - (listp (cdr mslocs))) - mslocs (list mslocs)))) - (dolist (msloc mslocs) - ;; Sometimes a language with DEFAULT is different from - ;; with SYS_DEFAULT, and on my system - ;; (set-current-locale "chinese") is NOT the same as - ;; (set-current-locale "chinese-default")! The latter - ;; gives Taiwan (DEFAULT), the former PRC (SYS_DEFAULT). - ;; In the interests of consistency, we always use DEFAULT. - (or (consp msloc) (setq msloc (cons msloc "DEFAULT"))) - (when (condition-case nil - (progn - (declare-fboundp (mswindows-set-current-locale - msloc)) - t) - (error nil)) - (return msloc)))))))) + (labels + ((mswindows-get-and-set-locale-from-langenv (langenv) + ;; find the mswindows locale for the langenv, make it current, + ;; and return it. first we check the langenv-to-locale table + ;; ... + (let ((ms-locale + (gethash langenv mswindows-langenv-to-locale-table))) + (if ms-locale (progn + (declare-fboundp (mswindows-set-current-locale + ms-locale)) + ms-locale) + ;; ... if not, see if the langenv specifies any locale(s). + ;; if not, construct one from the langenv name. + (let* ((mslocs (get-language-info langenv 'mswindows-locale)) + (mslocs (or mslocs (cons (upcase langenv) "DEFAULT"))) + (mslocs (if (and (consp mslocs) + (listp (cdr mslocs))) + mslocs (list mslocs)))) + (dolist (msloc mslocs) + ;; Sometimes a language with DEFAULT is different from + ;; with SYS_DEFAULT, and on my system + ;; (set-current-locale "chinese") is NOT the same as + ;; (set-current-locale "chinese-default")! The latter + ;; gives Taiwan (DEFAULT), the former PRC (SYS_DEFAULT). + ;; In the interests of consistency, we always use DEFAULT. + (or (consp msloc) (setq msloc (cons msloc "DEFAULT"))) + (when (condition-case nil + (progn + (declare-fboundp (mswindows-set-current-locale + msloc)) + t) + (error nil)) + (return msloc)))))))) (if (eq system-type 'windows-nt) (let ((ms-locale (mswindows-get-and-set-locale-from-langenv langenv))) (when ms-locale @@ -1339,13 +1340,13 @@ ; Russian, ISO-2022-JP will continue to be automatically recognized, since ; ISO-8859-5 and ISO-2022-JP are different coding categories.)" - (flet ((maybe-change-coding-system-with-eol (codesys eol-type) - ;; if the EOL type specifies a specific type of ending, - ;; then add that ending onto the given CODESYS; otherwise, - ;; return CODESYS unchanged. - (if (memq eol-type '(lf crlf cr unix dos mac)) - (coding-system-change-eol-conversion codesys eol-type) - codesys))) + (labels ((maybe-change-coding-system-with-eol (codesys eol-type) + ;; if the EOL type specifies a specific type of ending, + ;; then add that ending onto the given CODESYS; otherwise, + ;; return CODESYS unchanged. + (if (memq eol-type '(lf crlf cr unix dos mac)) + (coding-system-change-eol-conversion codesys eol-type) + codesys))) ;; initialize category mappings and priority list. (let* ((priority (get-language-info language-name 'coding-priority))
--- a/lisp/mule/mule-x-init.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/mule/mule-x-init.el Wed Sep 07 21:21:36 2011 +0100 @@ -39,14 +39,14 @@ occupy exactly twice the screen space of ASCII (`halfwidth') characters. On many systems, e.g. Sun CDE systems, this can only be achieved by using a national variant roman font to display ASCII." - (flet ((charset-font-width (charset) - (font-instance-width - (face-font-instance 'default (selected-device) charset))) + (labels ((charset-font-width (charset) + (font-instance-width + (face-font-instance 'default (selected-device) charset))) - (twice-as-wide (cs1 cs2) - (let ((width1 (charset-font-width cs1)) - (width2 (charset-font-width cs2))) - (and width1 width2 (eq (+ width1 width1) width2))))) + (twice-as-wide (cs1 cs2) + (let ((width1 (charset-font-width cs1)) + (width2 (charset-font-width cs2))) + (and width1 width2 (eq (+ width1 width1) width2))))) (when (eq 'x (device-type)) (let ((original-registries (charset-registries 'ascii)))
--- a/lisp/simple.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/simple.el Wed Sep 07 21:21:36 2011 +0100 @@ -2638,21 +2638,21 @@ (defun transpose-subr (mover arg &optional move-region) (let (start1 end1 start2 end2) - ;; XEmacs -- use flet instead of defining a separate function and + ;; XEmacs -- use labels instead of defining a separate function and ;; relying on dynamic scope; use (mark t) etc; add code to support ;; the new MOVE-REGION arg. - (flet ((transpose-subr-1 () - (if (> (min end1 end2) (max start1 start2)) - (error "Don't have two things to transpose")) - (let ((word1 (buffer-substring start1 end1)) - (word2 (buffer-substring start2 end2))) - (delete-region start2 end2) - (goto-char start2) - (insert word1) - (goto-char (if (< start1 start2) start1 - (+ start1 (- (length word1) (length word2))))) - (delete-char (length word1)) - (insert word2)))) + (labels ((transpose-subr-1 () + (if (> (min end1 end2) (max start1 start2)) + (error "Don't have two things to transpose")) + (let ((word1 (buffer-substring start1 end1)) + (word2 (buffer-substring start2 end2))) + (delete-region start2 end2) + (goto-char start2) + (insert word1) + (goto-char (if (< start1 start2) start1 + (+ start1 (- (length word1) (length word2))))) + (delete-char (length word1)) + (insert word2)))) (if (= arg 0) (progn (save-excursion
--- a/lisp/specifier.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/specifier.el Wed Sep 07 21:21:36 2011 +0100 @@ -484,10 +484,10 @@ (let-specifier ((modeline-shadow-thickness 0 (selected-window))) (sit-for 1))" (check-argument-type 'listp specifier-list) - (flet ((gensym-frob (x name) - (if (or (atom x) (eq (car x) 'quote)) - (list x) - (list (gensym name) x)))) + (labels ((gensym-frob (x name) + (if (or (atom x) (eq (car x) 'quote)) + (list x) + (list (gensym name) x)))) ;; VARLIST is a list of ;; ((SPECIFIERSYM SPECIFIER) (VALUE) (LOCALESYM LOCALE) ;; (TAG-SET) (HOW-TO-ADD)) @@ -854,11 +854,9 @@ (or try-stages (setq try-stages 1)) (if (eq try-stages t) (setq try-stages 3)) (check-argument-range try-stages 1 3) - (flet ((delete-wrong-type (x) - (delete-if-not - #'(lambda (y) - (device-type-matches-spec y devtype-spec)) - x))) + (labels ((delete-wrong-type (x) + (delete-if-not + #'(lambda (y) (device-type-matches-spec y devtype-spec)) x))) (let ((both (intersection (if current-device (list (device-type current-device))
--- a/lisp/test-harness.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/test-harness.el Wed Sep 07 21:21:36 2011 +0100 @@ -713,11 +713,11 @@ ;; probably should just use (length "byte-compiler-tests.el") ;; and 5-place sizes -- this will also work for the file-by-file ;; printing when Adrian's kludge gets reverted - (flet ((print-width (i) - (let ((x 10) (y 1)) - (while (>= i x) - (setq x (* 10 x) y (1+ y))) - y))) + (labels ((print-width (i) + (let ((x 10) (y 1)) + (while (>= i x) + (setq x (* 10 x) y (1+ y))) + y))) (while results (let* ((head (car results)) (nn (length (file-name-nondirectory (first head))))
--- a/lisp/x-compose.el Wed Sep 07 16:26:45 2011 +0100 +++ b/lisp/x-compose.el Wed Sep 07 21:21:36 2011 +0100 @@ -865,14 +865,14 @@ ;; Make colon equivalent to doublequote for diaeresis processing. Some ;; Xlibs do this. -(flet ((alias-colon-to-doublequote (keymap) - (map-keymap - #'(lambda (key value) - (when (keymapp value) - (alias-colon-to-doublequote value)) - (when (eq key '\") - (define-key keymap ":" value))) - keymap))) +(labels ((alias-colon-to-doublequote (keymap) + (map-keymap + #'(lambda (key value) + (when (keymapp value) + (alias-colon-to-doublequote value)) + (when (eq key '\") + (define-key keymap ":" value))) + keymap))) (alias-colon-to-doublequote compose-map)) ;;; Electric dead keys: making a' mean a-acute.