From 4701091fb20fe41f824040bd0ce4513a58b00468 Mon Sep 17 00:00:00 2001 From: Katsumi Yamaoka Date: Tue, 4 Dec 2012 08:21:42 +0000 Subject: [PATCH] gmm-utils.el (gmm-flet, gmm-labels): New macros. gnus-sync.el (gnus-sync-lesync-call) message.el (message-read-from-minibuffer): Use gmm-flet. gnus-score.el (gnus-score-decode-text-parts): Use gmm-labels. gnus-util.el (gnus-macroexpand-all): Remove. contrib/gnus-namazu.el (gnus-namazu/update-p): Use gmm-labels. --- contrib/ChangeLog | 4 +++ contrib/gnus-namazu.el | 7 ++--- lisp/ChangeLog | 11 ++++++++ lisp/gmm-utils.el | 60 ++++++++++++++++++++++++++++++++++++++++++ lisp/gnus-score.el | 52 +++++++++++++++++++----------------- lisp/gnus-sync.el | 3 ++- lisp/gnus-util.el | 21 --------------- lisp/message.el | 2 +- 8 files changed, 110 insertions(+), 50 deletions(-) diff --git a/contrib/ChangeLog b/contrib/ChangeLog index 6f8726210..e4b20c0a8 100644 --- a/contrib/ChangeLog +++ b/contrib/ChangeLog @@ -1,3 +1,7 @@ +2012-12-04 Katsumi Yamaoka + + * gnus-namazu.el (gnus-namazu/update-p): Use gmm-labels. + 2012-11-08 TSUCHIYA Masatoshi * gnus-namazu.el (gnus-namazu/make-directory-table): Bind diff --git a/contrib/gnus-namazu.el b/contrib/gnus-namazu.el index cb57c5e57..7e36c79c2 100644 --- a/contrib/gnus-namazu.el +++ b/contrib/gnus-namazu.el @@ -101,6 +101,7 @@ (require 'nnheader) (require 'nnmail) (require 'gnus-sum) +(require 'gmm-util) ;; To suppress byte-compile warning. (eval-when-compile @@ -780,9 +781,9 @@ than the period that is set to `gnus-namazu-index-update-interval'" (defun gnus-namazu/update-p (directory &optional force) "Return the DIRECTORY when the index undef the DIRECTORY should be updated." (setq directory (file-name-as-directory (expand-file-name directory))) - (labels ((error-message (format &rest args) - (apply (if force 'error 'message) format args) - nil)) + (gmm-labels ((error-message (format &rest args) + (apply (if force 'error 'message) format args) + nil)) (if gnus-namazu/update-process (error-message "%s" "Can not run two update processes simultaneously") (and (or force diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 86b29de58..b88504a4c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,14 @@ +2012-12-04 Katsumi Yamaoka + + * gmm-utils.el (gmm-flet, gmm-labels): New macros. + + * gnus-sync.el (gnus-sync-lesync-call) + * message.el (message-read-from-minibuffer): Use gmm-flet. + + * gnus-score.el (gnus-score-decode-text-parts): Use gmm-labels. + + * gnus-util.el (gnus-macroexpand-all): Remove. + 2012-12-03 Andreas Schwab * gnus-sum.el (gnus-summary-mode-map): Bind gnus-summary-widget-forward diff --git a/lisp/gmm-utils.el b/lisp/gmm-utils.el index 975b83370..3d504d73c 100644 --- a/lisp/gmm-utils.el +++ b/lisp/gmm-utils.el @@ -417,6 +417,66 @@ coding-system." (write-region start end filename append visit lockname)) (write-region start end filename append visit lockname mustbenew))) +;; `flet' and `labels' got obsolete since Emacs 24.3. +(defmacro gmm-flet (bindings &rest body) + "Make temporary overriding function definitions. + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + `(let (fn origs) + (dolist (bind ',bindings) + (setq fn (car bind)) + (push (cons fn (and (fboundp fn) (symbol-function fn))) origs) + (fset fn (cons 'lambda (cdr bind)))) + (unwind-protect + (progn ,@body) + (dolist (orig origs) + (if (cdr orig) + (fset (car orig) (cdr orig)) + (fmakunbound (car orig))))))) +(put 'gmm-flet 'lisp-indent-function 1) + +;; An alist of original function names and those unique names. +(defvar gmm-labels-environment) + +(defun gmm-labels-expand (form) + "Expand funcalls in FORM according to `gmm-labels-environment'. +This function is a subroutine that `gmm-labels' uses to convert any +`(FN ...)' and #'FN elements in FORM into `(funcall UN ...)' and `UN' +respectively if `(FN . UN)' is listed in `gmm-labels-environment'." + (cond ((or (not (consp form)) (memq (car form) '(\` backquote quote))) + form) + ((assq (car form) gmm-labels-environment) + `(funcall ,(cdr (assq (car form) gmm-labels-environment)) + ,@(mapcar #'gmm-labels-expand (cdr form)))) + ((eq (car form) 'function) + (if (and (assq (cadr form) gmm-labels-environment) + (not (cddr form))) + (cdr (assq (cadr form) gmm-labels-environment)) + (cons 'function (mapcar #'gmm-labels-expand (cdr form))))) + (t + (mapcar #'gmm-labels-expand form)))) + +(defmacro gmm-labels (bindings &rest body) + "Make temporary function bindings. +The lexical scoping is handled via `lexical-let' rather than relying +on `lexical-binding'. + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + (let (gmm-labels-environment def defs) + (dolist (binding bindings) + (push (cons (car binding) + (make-symbol (format "--gmm-%s--" (car binding)))) + gmm-labels-environment)) + `(lexical-let ,(mapcar #'cdr gmm-labels-environment) + (setq ,@(dolist (env gmm-labels-environment (nreverse defs)) + (setq def (cdr (assq (car env) bindings))) + (push (cdr env) defs) + (push `(lambda ,(car def) + ,@(mapcar #'gmm-labels-expand (cdr def))) + defs))) + ,@(mapcar #'gmm-labels-expand body)))) +(put 'gmm-labels 'lisp-indent-function 1) + (provide 'gmm-utils) ;;; gmm-utils.el ends here diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el index b70619608..f7a507fd1 100644 --- a/lisp/gnus-score.el +++ b/lisp/gnus-score.el @@ -33,6 +33,7 @@ (require 'gnus-win) (require 'message) (require 'score-mode) +(require 'gmm-utils) (defcustom gnus-global-score-files nil "List of global score files and directories. @@ -1718,33 +1719,36 @@ score in `gnus-newsgroup-scored' by SCORE." nil) (defun gnus-score-decode-text-parts () - (labels ((mm-text-parts (handle) - (cond ((stringp (car handle)) - (let ((parts (mapcan #'mm-text-parts (cdr handle)))) - (if (equal "multipart/alternative" (car handle)) - ;; pick the first supported alternative - (list (car parts)) - parts))) - - ((bufferp (car handle)) - (when (string-match "^text/" (mm-handle-media-type handle)) - (list handle))) - - (t (mapcan #'mm-text-parts handle)))) - (my-mm-display-part (handle) - (when handle - (save-restriction - (narrow-to-region (point) (point)) - (mm-display-inline handle) - (goto-char (point-max)))))) + (gmm-labels + ((mm-text-parts + (handle) + (cond ((stringp (car handle)) + (let ((parts (mapcan #'mm-text-parts (cdr handle)))) + (if (equal "multipart/alternative" (car handle)) + ;; pick the first supported alternative + (list (car parts)) + parts))) + + ((bufferp (car handle)) + (when (string-match "^text/" (mm-handle-media-type handle)) + (list handle))) + + (t (mapcan #'mm-text-parts handle)))) + (my-mm-display-part + (handle) + (when handle + (save-restriction + (narrow-to-region (point) (point)) + (mm-display-inline handle) + (goto-char (point-max)))))) (let (;(mm-text-html-renderer 'w3m-standalone) - (handles (mm-dissect-buffer t))) + (handles (mm-dissect-buffer t))) (save-excursion - (article-goto-body) - (delete-region (point) (point-max)) - (mapc #'my-mm-display-part (mm-text-parts handles)) - handles)))) + (article-goto-body) + (delete-region (point) (point-max)) + (mapc #'my-mm-display-part (mm-text-parts handles)) + handles)))) (defun gnus-score-body (scores header now expire &optional trace) (if gnus-agent-fetching diff --git a/lisp/gnus-sync.el b/lisp/gnus-sync.el index 6930ef3b2..8584e9422 100644 --- a/lisp/gnus-sync.el +++ b/lisp/gnus-sync.el @@ -99,6 +99,7 @@ (require 'gnus) (require 'gnus-start) (require 'gnus-util) +(require 'gmm-utils) (defvar gnus-topic-alist) ;; gnus-group.el (eval-when-compile @@ -187,7 +188,7 @@ and `gnus-topic-alist'. Also see `gnus-variable-list'." (defun gnus-sync-lesync-call (url method headers &optional kvdata) "Make an access request to URL using KVDATA and METHOD. KVDATA must be an alist." - (flet ((json-alist-p (list) (gnus-sync-json-alist-p list))) ; temp patch + (gmm-flet ((json-alist-p (list) (gnus-sync-json-alist-p list))) ; temp patch (let ((url-request-method method) (url-request-extra-headers headers) (url-request-data (if kvdata (json-encode kvdata) nil))) diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index f5e1077f8..7b1e2b5c7 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1938,27 +1938,6 @@ to case differences." (string-equal (downcase str1) (downcase prefix)) (string-equal str1 prefix)))))) -(eval-and-compile - (if (fboundp 'macroexpand-all) - (defalias 'gnus-macroexpand-all 'macroexpand-all) - (defun gnus-macroexpand-all (form &optional environment) - "Return result of expanding macros at all levels in FORM. -If no macros are expanded, FORM is returned unchanged. -The second optional arg ENVIRONMENT specifies an environment of macro -definitions to shadow the loaded ones for use in file byte-compilation." - (if (consp form) - (let ((idx 1) - (len (length (setq form (copy-sequence form)))) - expanded) - (while (< idx len) - (setcar (nthcdr idx form) (gnus-macroexpand-all (nth idx form) - environment)) - (setq idx (1+ idx))) - (if (eq (setq expanded (macroexpand form environment)) form) - form - (gnus-macroexpand-all expanded environment))) - form)))) - ;; Simple check: can be a macro but this way, although slow, it's really clear. ;; We don't use `bound-and-true-p' because it's not in XEmacs. (defun gnus-bound-and-true-p (sym) diff --git a/lisp/message.el b/lisp/message.el index 2c4f2038c..32d0edffb 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -8185,7 +8185,7 @@ regexp VARSTR." (if (fboundp 'mail-abbrevs-setup) (let ((minibuffer-setup-hook 'mail-abbrevs-setup) (minibuffer-local-map message-minibuffer-local-map)) - (flet ((mail-abbrev-in-expansion-header-p nil t)) + (gmm-flet ((mail-abbrev-in-expansion-header-p nil t)) (read-from-minibuffer prompt initial-contents))) (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook) (minibuffer-local-map message-minibuffer-local-map)) -- 2.25.1