From 46a2cc4470732ec3d8ac152932704bbcf394ee67 Mon Sep 17 00:00:00 2001 From: Katsumi Yamaoka Date: Tue, 4 Dec 2012 08:22:12 +0000 Subject: [PATCH 1/1] 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. --- lisp/gnus/ChangeLog | 11 ++++++++ lisp/gnus/gmm-utils.el | 60 +++++++++++++++++++++++++++++++++++++++++ lisp/gnus/gnus-score.el | 52 ++++++++++++++++++----------------- lisp/gnus/gnus-sync.el | 3 ++- lisp/gnus/gnus-util.el | 21 --------------- lisp/gnus/message.el | 2 +- 6 files changed, 102 insertions(+), 47 deletions(-) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 0aef3732ad..f625771cdb 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/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/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index 975b83370b..3d504d73ce 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/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/gnus-score.el b/lisp/gnus/gnus-score.el index b706196083..f7a507fd1d 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/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/gnus-sync.el b/lisp/gnus/gnus-sync.el index 493025cbe1..e2a71f0ee0 100644 --- a/lisp/gnus/gnus-sync.el +++ b/lisp/gnus/gnus-sync.el @@ -88,6 +88,7 @@ (require 'gnus) (require 'gnus-start) (require 'gnus-util) +(require 'gmm-utils) (defvar gnus-topic-alist) ;; gnus-group.el (eval-when-compile @@ -176,7 +177,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/gnus-util.el b/lisp/gnus/gnus-util.el index f5e1077f8c..7b1e2b5c79 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/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/gnus/message.el b/lisp/gnus/message.el index 5a2b433458..2171dcf3ed 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -8141,7 +8141,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.20.1