Now on revision 108519. ------------------------------------------------------------ revno: 108519 committer: Katsumi Yamaoka branch nick: trunk timestamp: Fri 2012-06-08 04:38:56 +0000 message: Merge bugfixes done in Gnus trunk Those changes fix only the bugs having appeared in the bug list. Many other Gnus changes not yet merged to Emacs are in: ftp://ftp.jpl.org/pub/tmp/MaGnus-to-Emacs.patch (or http://www.jpl.org/ftp/pub/tmp/MaGnus-to-Emacs.patch) 2012-06-07 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-msg-mail): Warn the user about Gnus not running (bug#11514). 2012-04-10 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-summary-cancel-article): See what From header we would have gotten if we posted to the group, and use that to compare against the message we want to cancel (bug#10808). diff: === modified file 'lisp/gnus/ChangeLog' --- lisp/gnus/ChangeLog 2012-06-01 20:24:17 +0000 +++ lisp/gnus/ChangeLog 2012-06-08 04:38:56 +0000 @@ -1,3 +1,8 @@ +2012-06-07 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-msg-mail): Warn the user about Gnus not running + (bug#11514). + 2012-06-01 Stefan Monnier * nntp.el: Stop the `letf' madness. @@ -98,6 +103,12 @@ * gnus-start.el (gnus-read-newsrc-el-file): Protect against broken .newsrc.el files. +2012-04-10 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-summary-cancel-article): See what From header we + would have gotten if we posted to the group, and use that to compare + against the message we want to cancel (bug#10808). + 2012-03-22 Lars Magne Ingebrigtsen * auth-source.el (auth-source-netrc-create): Quote tokens that contain === modified file 'lisp/gnus/gnus-msg.el' --- lisp/gnus/gnus-msg.el 2012-05-21 23:29:03 +0000 +++ lisp/gnus/gnus-msg.el 2012-06-08 04:38:56 +0000 @@ -487,8 +487,10 @@ instead." (interactive) (if (not (gnus-alive-p)) - (message-mail to subject other-headers continue - nil yank-action send-actions return-action) + (progn + (message "Gnus not running; using plain Message mode") + (message-mail to subject other-headers continue + nil yank-action send-actions return-action)) (let ((buf (current-buffer)) (gnus-newsgroup-name (or gnus-newsgroup-name "")) mail-buf) @@ -810,9 +812,21 @@ (interactive (gnus-interactive "P\ny")) (let ((message-post-method `(lambda (arg) - (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name)))) + (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name))) + (user-mail-address user-mail-address)) (dolist (article (gnus-summary-work-articles n)) (when (gnus-summary-select-article t nil nil article) + ;; Pretend that we're doing a followup so that we can see what + ;; the From header would have ended up being. + (save-window-excursion + (save-excursion + (gnus-summary-followup nil) + (let ((from (message-fetch-field "from"))) + (when from + (setq user-mail-address + (car (mail-header-parse-address from))))) + (kill-buffer (current-buffer)))) + ;; Now cancel the article using the From header we got. (when (gnus-eval-in-buffer-window gnus-original-article-buffer (message-cancel-news)) (gnus-summary-mark-as-read article gnus-canceled-mark) ------------------------------------------------------------ revno: 108518 committer: Sam Steingold branch nick: trunk timestamp: Fri 2012-06-08 00:23:26 -0400 message: * lisp/bindings.el (global-map): Bind XF86Forward to next-buffer and XF86Back to previous-buffer. (minibuffer-local-map): Bind them to next-history-element and previous-history-element respectively. * lisp/help-mode.el (help-mode-map): Bind them to help-go-forward and help-go-back respectively. * lisp/info.el (Info-mode-map): Bind them to Info-history-forward and Info-history-back respectively. These are the keys next to Up on the ThinkPad keyboard. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-08 02:54:35 +0000 +++ lisp/ChangeLog 2012-06-08 04:23:26 +0000 @@ -1,3 +1,15 @@ +2012-06-08 Sam Steingold + + * bindings.el (global-map): Bind XF86Forward to next-buffer and + XF86Back to previous-buffer. + (minibuffer-local-map): Bind them to next-history-element and + previous-history-element respectively. + * help-mode.el (help-mode-map): Bind them to help-go-forward and + help-go-back respectively. + * info.el (Info-mode-map): Bind them to Info-history-forward and + Info-history-back respectively. + These are the keys next to Up on the ThinkPad keyboard. + 2012-06-08 Stefan Monnier Get rid of cl-lexical-let, keeping only lexical-let for compatibility. === modified file 'lisp/bindings.el' --- lisp/bindings.el 2012-06-03 10:54:22 +0000 +++ lisp/bindings.el 2012-06-08 04:23:26 +0000 @@ -784,16 +784,20 @@ (define-key ctl-x-map [right] 'next-buffer) (define-key ctl-x-map [C-right] 'next-buffer) +(define-key global-map [XF86Forward] 'next-buffer) (define-key ctl-x-map [left] 'previous-buffer) (define-key ctl-x-map [C-left] 'previous-buffer) +(define-key global-map [XF86Back] 'previous-buffer) (let ((map minibuffer-local-map)) (define-key map "\en" 'next-history-element) (define-key map [next] 'next-history-element) (define-key map [down] 'next-history-element) + (define-key map [XF86Forward] 'next-history-element) (define-key map "\ep" 'previous-history-element) (define-key map [prior] 'previous-history-element) (define-key map [up] 'previous-history-element) + (define-key map [XF86Back] 'previous-history-element) (define-key map "\es" 'next-matching-history-element) (define-key map "\er" 'previous-matching-history-element) ;; Override the global binding (which calls indent-relative via === modified file 'lisp/help-mode.el' --- lisp/help-mode.el 2012-01-19 07:21:25 +0000 +++ lisp/help-mode.el 2012-06-08 04:23:26 +0000 @@ -40,6 +40,8 @@ (define-key map [mouse-2] 'help-follow-mouse) (define-key map "\C-c\C-b" 'help-go-back) (define-key map "\C-c\C-f" 'help-go-forward) + (define-key map [XF86Back] 'help-go-back) + (define-key map [XF86Forward] 'help-go-forward) (define-key map "\C-c\C-c" 'help-follow-symbol) (define-key map "\r" 'help-follow) map) === modified file 'lisp/info.el' --- lisp/info.el 2012-05-29 09:09:38 +0000 +++ lisp/info.el 2012-06-08 04:23:26 +0000 @@ -3758,6 +3758,8 @@ (define-key map "\177" 'Info-scroll-down) (define-key map [mouse-2] 'Info-mouse-follow-nearest-node) (define-key map [follow-link] 'mouse-face) + (define-key map [XF86Back] 'Info-history-back) + (define-key map [XF86Forward] 'Info-history-forward) map) "Keymap containing Info commands.") ------------------------------------------------------------ revno: 108517 committer: Stefan Monnier branch nick: trunk timestamp: Thu 2012-06-07 22:54:35 -0400 message: Get rid of cl-lexical-let, keeping only lexical-let for compatibility. * lisp/emacs-lisp/cl-macs.el: Provide itself. (cl--labels-convert-cache): New var. (cl--labels-convert): New function. (cl-flet, cl-labels): New implementation with new semantics, relying on lexical-binding. * lisp/emacs-lisp/cl.el: Mark compatibility aliases as obsolete. (cl-closure-vars, cl--function-convert-cache) (cl--function-convert): Move from cl-macs.el. (lexical-let, lexical-let*, flet, labels): Move from cl-macs.el and rename by removing the "cl-" prefix. * lisp/emacs-lisp/macroexp.el (macroexp-unprogn): New function. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-07 19:48:22 +0000 +++ lisp/ChangeLog 2012-06-08 02:54:35 +0000 @@ -1,3 +1,18 @@ +2012-06-08 Stefan Monnier + + Get rid of cl-lexical-let, keeping only lexical-let for compatibility. + * emacs-lisp/cl-macs.el: Provide itself. + (cl--labels-convert-cache): New var. + (cl--labels-convert): New function. + (cl-flet, cl-labels): New implementation with new semantics, relying on + lexical-binding. + * emacs-lisp/cl.el: Mark compatibility aliases as obsolete. + (cl-closure-vars, cl--function-convert-cache) + (cl--function-convert): Move from cl-macs.el. + (lexical-let, lexical-let*, flet, labels): Move from cl-macs.el and + rename by removing the "cl-" prefix. + * emacs-lisp/macroexp.el (macroexp-unprogn): New function. + 2012-06-07 Stefan Monnier * emacs-lisp/cl.el (cl-macroexpand, cl-macro-environment) === modified file 'lisp/emacs-lisp/cl-loaddefs.el' --- lisp/emacs-lisp/cl-loaddefs.el 2012-06-07 19:48:22 +0000 +++ lisp/emacs-lisp/cl-loaddefs.el 2012-06-08 02:54:35 +0000 @@ -258,13 +258,12 @@ ;;;;;; cl-letf cl-rotatef cl-shiftf cl-remf cl-do-pop cl-psetf cl-setf ;;;;;; cl-get-setf-method cl-defsetf cl-define-setf-expander cl-declare ;;;;;; cl-the cl-locally cl-multiple-value-setq cl-multiple-value-bind -;;;;;; cl-lexical-let* cl-lexical-let cl-symbol-macrolet cl-macrolet -;;;;;; cl-labels cl-flet cl-progv cl-psetq cl-do-all-symbols cl-do-symbols -;;;;;; cl-dotimes cl-dolist cl-do* cl-do cl-loop cl-return-from -;;;;;; cl-return cl-block cl-etypecase cl-typecase cl-ecase cl-case -;;;;;; cl-load-time-value cl-eval-when cl-destructuring-bind cl-function -;;;;;; cl-defmacro cl-defun cl-gentemp cl-gensym) "cl-macs" "cl-macs.el" -;;;;;; "c1e8e5391e374630452ab3d78e527086") +;;;;;; cl-symbol-macrolet cl-macrolet cl-labels cl-flet cl-progv +;;;;;; cl-psetq cl-do-all-symbols cl-do-symbols cl-dotimes cl-dolist +;;;;;; cl-do* cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase +;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when +;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp +;;;;;; cl-gensym) "cl-macs" "cl-macs.el" "4c0f605e3c7454488cc9d498b611f422") ;;; Generated autoloads from cl-macs.el (autoload 'cl-gensym "cl-macs" "\ @@ -485,10 +484,7 @@ (autoload 'cl-flet "cl-macs" "\ Make temporary function definitions. -This is an analogue of `let' that operates on the function cell of FUNC -rather than its value cell. The FORMs are evaluated with the specified -function definitions in place, then the definitions are undone (the FUNCs -go back to their previous definitions, or lack thereof). +Like `cl-labels' but the definitions are not recursive. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil t) @@ -496,8 +492,7 @@ (autoload 'cl-labels "cl-macs" "\ Make temporary function bindings. -This is like `cl-flet', except the bindings are lexical instead of dynamic. -Unlike `cl-flet', this macro is fully compliant with the Common Lisp standard. +The bindings can be recursive. Assumes the use of `lexical-binding'. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil t) @@ -520,26 +515,6 @@ (put 'cl-symbol-macrolet 'lisp-indent-function '1) -(autoload 'cl-lexical-let "cl-macs" "\ -Like `let', but lexically scoped. -The main visible difference is that lambdas inside BODY will create -lexical closures as in Common Lisp. - -\(fn BINDINGS BODY)" nil t) - -(put 'cl-lexical-let 'lisp-indent-function '1) - -(autoload 'cl-lexical-let* "cl-macs" "\ -Like `let*', but lexically scoped. -The main visible difference is that lambdas inside BODY, and in -successive bindings within BINDINGS, will create lexical closures -as in Common Lisp. This is similar to the behavior of `let*' in -Common Lisp. - -\(fn BINDINGS BODY)" nil t) - -(put 'cl-lexical-let* 'lisp-indent-function '1) - (autoload 'cl-multiple-value-bind "cl-macs" "\ Collect multiple return values. FORM must return a list; the BODY is then executed with the first N elements === modified file 'lisp/emacs-lisp/cl-macs.el' --- lisp/emacs-lisp/cl-macs.el 2012-06-07 19:48:22 +0000 +++ lisp/emacs-lisp/cl-macs.el 2012-06-08 02:54:35 +0000 @@ -1611,63 +1611,70 @@ (progn (cl-progv-before ,symbols ,values) ,@body) (cl-progv-after)))) +(defvar cl--labels-convert-cache nil) + +(defun cl--labels-convert (f) + "Special macro-expander to rename (function F) references in `cl-labels'." + (cond + ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked + ;; *after* handling `function', but we want to stop macroexpansion from + ;; being applied infinitely, so we use a cache to return the exact `form' + ;; being expanded even though we don't receive it. + ((eq f (car cl--labels-convert-cache)) (cdr cl--labels-convert-cache)) + (t + (let ((found (assq f macroexpand-all-environment))) + (if (and found (ignore-errors + (eq (cadr (cl-caddr found)) 'cl-labels-args))) + (cadr (cl-caddr (cl-cadddr found))) + (let ((res `(function ,f))) + (setq cl--labels-convert-cache (cons f res)) + res)))))) + ;;; This should really have some way to shadow 'byte-compile properties, etc. ;;;###autoload (defmacro cl-flet (bindings &rest body) "Make temporary function definitions. -This is an analogue of `let' that operates on the function cell of FUNC -rather than its value cell. The FORMs are evaluated with the specified -function definitions in place, then the definitions are undone (the FUNCs -go back to their previous definitions, or lack thereof). +Like `cl-labels' but the definitions are not recursive. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) - `(cl-letf* ,(mapcar - (lambda (x) - (if (or (and (fboundp (car x)) - (eq (car-safe (symbol-function (car x))) 'macro)) - (cdr (assq (car x) macroexpand-all-environment))) - (error "Use `cl-labels', not `cl-flet', to rebind macro names")) - (let ((func `(cl-function - (lambda ,(cadr x) - (cl-block ,(car x) ,@(cddr x)))))) - (when (cl-compiling-file) - ;; Bug#411. It would be nice to fix this. - (and (get (car x) 'byte-compile) - (error "Byte-compiling a redefinition of `%s' \ -will not work - use `cl-labels' instead" (symbol-name (car x)))) - ;; FIXME This affects the rest of the file, when it - ;; should be restricted to the cl-flet body. - (and (boundp 'byte-compile-function-environment) - (push (cons (car x) (eval func)) - byte-compile-function-environment))) - (list `(symbol-function ',(car x)) func))) - bindings) - ,@body)) + (let ((binds ()) (newenv macroexpand-all-environment)) + (dolist (binding bindings) + (let ((var (make-symbol (format "--cl-%s--" (car binding))))) + (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) + (push (cons (car binding) + `(lambda (&rest cl-labels-args) + (cl-list* 'funcall ',var + cl-labels-args))) + newenv))) + `(let ,(nreverse binds) + ,@(macroexp-unprogn + (macroexpand-all + `(progn ,@body) + ;; Don't override lexical-let's macro-expander. + (if (assq 'function newenv) newenv + (cons (cons 'function #'cl--labels-convert) newenv))))))) ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make temporary function bindings. -This is like `cl-flet', except the bindings are lexical instead of dynamic. -Unlike `cl-flet', this macro is fully compliant with the Common Lisp standard. +The bindings can be recursive. Assumes the use of `lexical-binding'. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug cl-flet)) - (let ((vars nil) (sets nil) (newenv macroexpand-all-environment)) - (while bindings - ;; Use `cl-gensym' rather than `make-symbol'. It's important that - ;; (not (eq (symbol-name var1) (symbol-name var2))) because these - ;; vars get added to the cl-macro-environment. - (let ((var (cl-gensym "--cl-var--"))) - (push var vars) - (push `(cl-function (lambda . ,(cdar bindings))) sets) - (push var sets) - (push (cons (car (pop bindings)) + (let ((binds ()) (newenv macroexpand-all-environment)) + (dolist (binding bindings) + (let ((var (make-symbol (format "--cl-%s--" (car binding))))) + (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) + (push (cons (car binding) `(lambda (&rest cl-labels-args) (cl-list* 'funcall ',var cl-labels-args))) newenv))) - (macroexpand-all `(cl-lexical-let ,vars (setq ,@sets) ,@body) newenv))) + (macroexpand-all `(letrec ,(nreverse binds) ,@body) + ;; Don't override lexical-let's macro-expander. + (if (assq 'function newenv) newenv + (cons (cons 'function #'cl--labels-convert) newenv))))) ;; The following ought to have a better definition for use with newer ;; byte compilers. @@ -1750,119 +1757,6 @@ macroexpand-all-environment))) (fset 'macroexpand previous-macroexpand)))))) -(defvar cl-closure-vars nil) -(defvar cl--function-convert-cache nil) - -(defun cl--function-convert (f) - "Special macro-expander for special cases of (function F). -The two cases that are handled are: -- closure-conversion of lambda expressions for `cl-lexical-let'. -- renaming of F when it's a function defined via `cl-labels'." - (cond - ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked - ;; *after* handling `function', but we want to stop macroexpansion from - ;; being applied infinitely, so we use a cache to return the exact `form' - ;; being expanded even though we don't receive it. - ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache)) - ((eq (car-safe f) 'lambda) - (let ((body (mapcar (lambda (f) - (macroexpand-all f macroexpand-all-environment)) - (cddr f)))) - (if (and cl-closure-vars - (cl--expr-contains-any body cl-closure-vars)) - (let* ((new (mapcar 'cl-gensym cl-closure-vars)) - (sub (cl-pairlis cl-closure-vars new)) (decls nil)) - (while (or (stringp (car body)) - (eq (car-safe (car body)) 'interactive)) - (push (list 'quote (pop body)) decls)) - (put (car (last cl-closure-vars)) 'used t) - `(list 'lambda '(&rest --cl-rest--) - ,@(cl-sublis sub (nreverse decls)) - (list 'apply - (list 'quote - #'(lambda ,(append new (cadr f)) - ,@(cl-sublis sub body))) - ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) - cl-closure-vars) - '((quote --cl-rest--)))))) - (let* ((newf `(lambda ,(cadr f) ,@body)) - (res `(function ,newf))) - (setq cl--function-convert-cache (cons newf res)) - res)))) - (t - (let ((found (assq f macroexpand-all-environment))) - (if (and found (ignore-errors - (eq (cadr (cl-caddr found)) 'cl-labels-args))) - (cadr (cl-caddr (cl-cadddr found))) - (let ((res `(function ,f))) - (setq cl--function-convert-cache (cons f res)) - res)))))) - -;;;###autoload -(defmacro cl-lexical-let (bindings &rest body) - "Like `let', but lexically scoped. -The main visible difference is that lambdas inside BODY will create -lexical closures as in Common Lisp. -\n(fn BINDINGS BODY)" - (declare (indent 1) (debug let)) - (let* ((cl-closure-vars cl-closure-vars) - (vars (mapcar (function - (lambda (x) - (or (consp x) (setq x (list x))) - (push (make-symbol (format "--cl-%s--" (car x))) - cl-closure-vars) - (set (car cl-closure-vars) [bad-lexical-ref]) - (list (car x) (cadr x) (car cl-closure-vars)))) - bindings)) - (ebody - (macroexpand-all - `(cl-symbol-macrolet - ,(mapcar (lambda (x) - `(,(car x) (symbol-value ,(cl-caddr x)))) - vars) - ,@body) - (cons (cons 'function #'cl--function-convert) - macroexpand-all-environment)))) - (if (not (get (car (last cl-closure-vars)) 'used)) - ;; Turn (let ((foo (cl-gensym))) - ;; (set foo ) ...(symbol-value foo)...) - ;; into (let ((foo )) ...(symbol-value 'foo)...). - ;; This is good because it's more efficient but it only works with - ;; dynamic scoping, since with lexical scoping we'd need - ;; (let ((foo )) ...foo...). - `(progn - ,@(mapcar (lambda (x) `(defvar ,(cl-caddr x))) vars) - (let ,(mapcar (lambda (x) (list (cl-caddr x) (cadr x))) vars) - ,(cl-sublis (mapcar (lambda (x) - (cons (cl-caddr x) - `',(cl-caddr x))) - vars) - ebody))) - `(let ,(mapcar (lambda (x) - (list (cl-caddr x) - `(make-symbol ,(format "--%s--" (car x))))) - vars) - (cl-setf ,@(apply #'append - (mapcar (lambda (x) - (list `(symbol-value ,(cl-caddr x)) (cadr x))) - vars))) - ,ebody)))) - -;;;###autoload -(defmacro cl-lexical-let* (bindings &rest body) - "Like `let*', but lexically scoped. -The main visible difference is that lambdas inside BODY, and in -successive bindings within BINDINGS, will create lexical closures -as in Common Lisp. This is similar to the behavior of `let*' in -Common Lisp. -\n(fn BINDINGS BODY)" - (declare (indent 1) (debug let)) - (if (null bindings) (cons 'progn body) - (setq bindings (reverse bindings)) - (while bindings - (setq body (list `(cl-lexical-let (,(pop bindings)) ,@body)))) - (car body))) - ;;; Multiple values. ;;;###autoload @@ -3211,4 +3105,6 @@ ;; generated-autoload-file: "cl-loaddefs.el" ;; End: +(provide 'cl-macs) + ;;; cl-macs.el ends here === modified file 'lisp/emacs-lisp/cl.el' --- lisp/emacs-lisp/cl.el 2012-06-07 19:48:22 +0000 +++ lisp/emacs-lisp/cl.el 2012-06-08 02:54:35 +0000 @@ -28,6 +28,7 @@ ;;; Code: (require 'cl-lib) +(require 'macroexp) ;; (defun cl--rename () ;; (let ((vdefs ()) @@ -226,11 +227,8 @@ locally multiple-value-setq multiple-value-bind - lexical-let* - lexical-let symbol-macrolet macrolet - labels flet progv psetq @@ -330,12 +328,181 @@ (if (get new prop) (put fun prop (get new prop)))))) +(defvar cl-closure-vars nil) +(defvar cl--function-convert-cache nil) + +(defun cl--function-convert (f) + "Special macro-expander for special cases of (function F). +The two cases that are handled are: +- closure-conversion of lambda expressions for `lexical-let'. +- renaming of F when it's a function defined via `cl-labels' or `labels'." + (require 'cl-macs) + (cond + ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked + ;; *after* handling `function', but we want to stop macroexpansion from + ;; being applied infinitely, so we use a cache to return the exact `form' + ;; being expanded even though we don't receive it. + ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache)) + ((eq (car-safe f) 'lambda) + (let ((body (mapcar (lambda (f) + (macroexpand-all f macroexpand-all-environment)) + (cddr f)))) + (if (and cl-closure-vars + (cl--expr-contains-any body cl-closure-vars)) + (let* ((new (mapcar 'cl-gensym cl-closure-vars)) + (sub (cl-pairlis cl-closure-vars new)) (decls nil)) + (while (or (stringp (car body)) + (eq (car-safe (car body)) 'interactive)) + (push (list 'quote (pop body)) decls)) + (put (car (last cl-closure-vars)) 'used t) + `(list 'lambda '(&rest --cl-rest--) + ,@(cl-sublis sub (nreverse decls)) + (list 'apply + (list 'quote + #'(lambda ,(append new (cadr f)) + ,@(cl-sublis sub body))) + ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) + cl-closure-vars) + '((quote --cl-rest--)))))) + (let* ((newf `(lambda ,(cadr f) ,@body)) + (res `(function ,newf))) + (setq cl--function-convert-cache (cons newf res)) + res)))) + (t + (let ((found (assq f macroexpand-all-environment))) + (if (and found (ignore-errors + (eq (cadr (cl-caddr found)) 'cl-labels-args))) + (cadr (cl-caddr (cl-cadddr found))) + (let ((res `(function ,f))) + (setq cl--function-convert-cache (cons f res)) + res)))))) + +(defmacro lexical-let (bindings &rest body) + "Like `let', but lexically scoped. +The main visible difference is that lambdas inside BODY will create +lexical closures as in Common Lisp. +\n(fn BINDINGS BODY)" + (declare (indent 1) (debug let)) + (let* ((cl-closure-vars cl-closure-vars) + (vars (mapcar (function + (lambda (x) + (or (consp x) (setq x (list x))) + (push (make-symbol (format "--cl-%s--" (car x))) + cl-closure-vars) + (set (car cl-closure-vars) [bad-lexical-ref]) + (list (car x) (cadr x) (car cl-closure-vars)))) + bindings)) + (ebody + (macroexpand-all + `(cl-symbol-macrolet + ,(mapcar (lambda (x) + `(,(car x) (symbol-value ,(cl-caddr x)))) + vars) + ,@body) + (cons (cons 'function #'cl--function-convert) + macroexpand-all-environment)))) + (if (not (get (car (last cl-closure-vars)) 'used)) + ;; Turn (let ((foo (cl-gensym))) + ;; (set foo ) ...(symbol-value foo)...) + ;; into (let ((foo )) ...(symbol-value 'foo)...). + ;; This is good because it's more efficient but it only works with + ;; dynamic scoping, since with lexical scoping we'd need + ;; (let ((foo )) ...foo...). + `(progn + ,@(mapcar (lambda (x) `(defvar ,(cl-caddr x))) vars) + (let ,(mapcar (lambda (x) (list (cl-caddr x) (cadr x))) vars) + ,(cl-sublis (mapcar (lambda (x) + (cons (cl-caddr x) + `',(cl-caddr x))) + vars) + ebody))) + `(let ,(mapcar (lambda (x) + (list (cl-caddr x) + `(make-symbol ,(format "--%s--" (car x))))) + vars) + (cl-setf ,@(apply #'append + (mapcar (lambda (x) + (list `(symbol-value ,(cl-caddr x)) (cadr x))) + vars))) + ,ebody)))) + +(defmacro lexical-let* (bindings &rest body) + "Like `let*', but lexically scoped. +The main visible difference is that lambdas inside BODY, and in +successive bindings within BINDINGS, will create lexical closures +as in Common Lisp. This is similar to the behavior of `let*' in +Common Lisp. +\n(fn BINDINGS BODY)" + (declare (indent 1) (debug let)) + (if (null bindings) (cons 'progn body) + (setq bindings (reverse bindings)) + (while bindings + (setq body (list `(lexical-let (,(pop bindings)) ,@body)))) + (car body))) + +;; This should really have some way to shadow 'byte-compile properties, etc. +;;;###autoload +(defmacro flet (bindings &rest body) + "Make temporary function definitions. +This is an analogue of `let' that operates on the function cell of FUNC +rather than its value cell. The FORMs are evaluated with the specified +function definitions in place, then the definitions are undone (the FUNCs +go back to their previous definitions, or lack thereof). + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + (declare (indent 1) (debug cl-flet)) + `(cl-letf* ,(mapcar + (lambda (x) + (if (or (and (fboundp (car x)) + (eq (car-safe (symbol-function (car x))) 'macro)) + (cdr (assq (car x) macroexpand-all-environment))) + (error "Use `labels', not `flet', to rebind macro names")) + (let ((func `(cl-function + (lambda ,(cadr x) + (cl-block ,(car x) ,@(cddr x)))))) + (when (cl-compiling-file) + ;; Bug#411. It would be nice to fix this. + (and (get (car x) 'byte-compile) + (error "Byte-compiling a redefinition of `%s' \ +will not work - use `labels' instead" (symbol-name (car x)))) + ;; FIXME This affects the rest of the file, when it + ;; should be restricted to the flet body. + (and (boundp 'byte-compile-function-environment) + (push (cons (car x) (eval func)) + byte-compile-function-environment))) + (list `(symbol-function ',(car x)) func))) + bindings) + ,@body)) + +(defmacro labels (bindings &rest body) + "Make temporary function bindings. +This is like `flet', except the bindings are lexical instead of dynamic. +Unlike `flet', this macro is fully compliant with the Common Lisp standard. + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + (declare (indent 1) (debug cl-flet)) + (let ((vars nil) (sets nil) (newenv macroexpand-all-environment)) + (dolist (binding bindings) + ;; It's important that (not (eq (symbol-name var1) (symbol-name var2))) + ;; because these var's *names* get added to the macro-environment. + (let ((var (make-symbol (format "--cl-%s--" (car binding))))) + (push var vars) + (push `(cl-function (lambda . ,(cdr binding))) sets) + (push var sets) + (push (cons (car binding) + `(lambda (&rest cl-labels-args) + (cl-list* 'funcall ',var + cl-labels-args))) + newenv))) + (macroexpand-all `(lexical-let ,vars (setq ,@sets) ,@body) newenv))) + ;;; Additional compatibility code ;; For names that were clean but really aren't needed any more. -(defalias 'cl-macroexpand 'macroexpand) -(defvaralias 'cl-macro-environment 'macroexpand-all-environment) -(defalias 'cl-macroexpand-all 'macroexpand-all) +(define-obsolete-function-alias 'cl-macroexpand 'macroexpand "24.2") +(define-obsolete-variable-alias 'cl-macro-environment + 'macroexpand-all-environment "24.2") +(define-obsolete-function-alias 'cl-macroexpand-all 'macroexpand-all "24.2") ;;; Hash tables. ;; This is just kept for compatibility with code byte-compiled by Emacs-20. @@ -343,24 +510,29 @@ ;; No idea if this might still be needed. (defun cl-not-hash-table (x &optional y &rest z) (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x)))) +(make-obsolete 'cl-not-hash-table nil "24.2") (defvar cl-builtin-gethash (symbol-function 'gethash)) +(make-obsolete-variable 'cl-builtin-gethash nil "24.2") (defvar cl-builtin-remhash (symbol-function 'remhash)) +(make-obsolete-variable 'cl-builtin-remhash nil "24.2") (defvar cl-builtin-clrhash (symbol-function 'clrhash)) +(make-obsolete-variable 'cl-builtin-clrhash nil "24.2") (defvar cl-builtin-maphash (symbol-function 'maphash)) -(defalias 'cl-map-keymap 'map-keymap) -(defalias 'cl-copy-tree 'copy-tree) -(defalias 'cl-gethash 'gethash) -(defalias 'cl-puthash 'puthash) -(defalias 'cl-remhash 'remhash) -(defalias 'cl-clrhash 'clrhash) -(defalias 'cl-maphash 'maphash) -(defalias 'cl-make-hash-table 'make-hash-table) -(defalias 'cl-hash-table-p 'hash-table-p) -(defalias 'cl-hash-table-count 'hash-table-count) +(make-obsolete-variable 'cl-builtin-maphash nil "24.2") +(define-obsolete-function-alias 'cl-map-keymap 'map-keymap "24.2") +(define-obsolete-function-alias 'cl-copy-tree 'copy-tree "24.2") +(define-obsolete-function-alias 'cl-gethash 'gethash "24.2") +(define-obsolete-function-alias 'cl-puthash 'puthash "24.2") +(define-obsolete-function-alias 'cl-remhash 'remhash "24.2") +(define-obsolete-function-alias 'cl-clrhash 'clrhash "24.2") +(define-obsolete-function-alias 'cl-maphash 'maphash "24.2") +(define-obsolete-function-alias 'cl-make-hash-table 'make-hash-table "24.2") +(define-obsolete-function-alias 'cl-hash-table-p 'hash-table-p "24.2") +(define-obsolete-function-alias 'cl-hash-table-count 'hash-table-count "24.2") -;; FIXME: More candidates: define-modify-macro, define-setf-expander, lexical-let. +;; FIXME: More candidates: define-modify-macro, define-setf-expander. (provide 'cl) ;;; cl.el ends here === modified file 'lisp/emacs-lisp/macroexp.el' --- lisp/emacs-lisp/macroexp.el 2012-06-07 19:25:48 +0000 +++ lisp/emacs-lisp/macroexp.el 2012-06-08 02:54:35 +0000 @@ -231,6 +231,10 @@ "Return an expression equivalent to `(progn ,@EXPS)." (if (cdr exps) `(progn ,@exps) (car exps))) +(defun macroexp-unprogn (exp) + "Turn EXP into a list of expressions to execute in sequence." + (if (eq (car-safe exp) 'progn) (cdr exp) (list exp))) + (defun macroexp-let* (bindings exp) "Return an expression equivalent to `(let* ,bindings ,exp)." (cond ------------------------------------------------------------ revno: 108516 committer: Stefan Monnier branch nick: trunk timestamp: Thu 2012-06-07 22:47:26 -0400 message: * src/eval.c (Fmacroexpand): Stop if the macro returns the same form. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-06-07 05:11:51 +0000 +++ src/ChangeLog 2012-06-08 02:47:26 +0000 @@ -1,3 +1,7 @@ +2012-06-08 Stefan Monnier + + * eval.c (Fmacroexpand): Stop if the macro returns the same form. + 2012-06-07 Paul Eggert * doprnt.c (doprnt): Truncate multibyte char correctly. === modified file 'src/eval.c' --- src/eval.c 2012-05-30 03:59:42 +0000 +++ src/eval.c 2012-06-08 02:47:26 +0000 @@ -1020,7 +1020,13 @@ if (NILP (expander)) break; } - form = apply1 (expander, XCDR (form)); + { + Lisp_Object newform = apply1 (expander, XCDR (form)); + if (EQ (form, newform)) + break; + else + form = newform; + } } return form; } ------------------------------------------------------------ revno: 108515 committer: Paul Eggert branch nick: trunk timestamp: Thu 2012-06-07 17:03:10 -0700 message: * texinfo.tex: Merge from gnulib. diff: === modified file 'doc/misc/ChangeLog' --- doc/misc/ChangeLog 2012-05-29 05:19:41 +0000 +++ doc/misc/ChangeLog 2012-06-08 00:03:10 +0000 @@ -1,3 +1,7 @@ +2012-06-08 Paul Eggert + + * texinfo.tex: Merge from gnulib. + 2012-05-29 Katsumi Yamaoka * Makefile.in (echo-info): Don't try to install info files named === modified file 'doc/misc/texinfo.tex' --- doc/misc/texinfo.tex 2012-05-26 23:14:36 +0000 +++ doc/misc/texinfo.tex 2012-06-08 00:03:10 +0000 @@ -3,7 +3,7 @@ % Load plain if necessary, i.e., if running under initex. \expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi % -\def\texinfoversion{2012-05-16.16} +\def\texinfoversion{2012-06-05.14} % % Copyright 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995, % 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, @@ -1117,7 +1117,7 @@ % #1 is a control sequence in which to do the replacements, % which we \xdef. \def\txiescapepdf#1{% - \ifx\pdfescapestring\relax + \ifx\pdfescapestring\thisisundefined % No primitive available; should we give a warning or log? % Many times it won't matter. \else ------------------------------------------------------------ revno: 108514 committer: Stefan Monnier branch nick: trunk timestamp: Thu 2012-06-07 15:48:22 -0400 message: Move old compatiblity to cl.el. Remove cl-macroexpand-all. * emacs-lisp/cl-extra.el (cl-map-keymap, cl-copy-tree) (cl-not-hash-table, cl-builtin-gethash, cl-builtin-remhash) (cl-builtin-clrhash, cl-builtin-maphash, cl-gethash, cl-puthash) (cl-remhash, cl-clrhash, cl-maphash, cl-make-hash-table) (cl-hash-table-p, cl-hash-table-count): Move to cl.el. (cl-macroexpand-cmacs): Remove var. (cl-macroexpand-all, cl-macroexpand-body): Remove funs. Use macroexpand-all instead. * emacs-lisp/cl-lib.el (cl-macro-environment): Remove decl. (cl-macroexpand): Move to cl-macs.el and rename to cl--sm-macroexpand. (cl-member): Remove old alias. * emacs-lisp/cl-macs.el (cl-macro-environment): Remove var. Use macroexpand-all-environment instead. (cl--old-macroexpand): New var. (cl--sm-macroexpand): New function. (cl-symbol-macrolet): Use it during macro expansion. (cl--function-convert-cache): New var. (cl--function-convert): New function, extracted from cl-macroexpand-all. (cl-lexical-let): Use it. * emacs-lisp/cl.el (cl-macroexpand, cl-macro-environment) (cl-macroexpand-all, cl-not-hash-table, cl-builtin-gethash) (cl-builtin-remhash, cl-builtin-clrhash, cl-builtin-maphash) (cl-map-keymap, cl-copy-tree, cl-gethash, cl-puthash, cl-remhash) (cl-clrhash, cl-maphash, cl-make-hash-table, cl-hash-table-p) (cl-hash-table-count): Add old compatibility aliases. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-07 19:25:48 +0000 +++ lisp/ChangeLog 2012-06-07 19:48:22 +0000 @@ -1,5 +1,37 @@ 2012-06-07 Stefan Monnier + * emacs-lisp/cl.el (cl-macroexpand, cl-macro-environment) + (cl-macroexpand-all, cl-not-hash-table, cl-builtin-gethash) + (cl-builtin-remhash, cl-builtin-clrhash, cl-builtin-maphash) + (cl-map-keymap, cl-copy-tree, cl-gethash, cl-puthash, cl-remhash) + (cl-clrhash, cl-maphash, cl-make-hash-table, cl-hash-table-p) + (cl-hash-table-count): Add old compatibility aliases. + + * emacs-lisp/cl-macs.el (cl-macro-environment): Remove var. + Use macroexpand-all-environment instead. + (cl--old-macroexpand): New var. + (cl--sm-macroexpand): New function. + (cl-symbol-macrolet): Use it during macro expansion. + (cl--function-convert-cache): New var. + (cl--function-convert): New function, extracted from + cl-macroexpand-all. + (cl-lexical-let): Use it. + + * emacs-lisp/cl-lib.el (cl-macro-environment): Remove decl. + (cl-macroexpand): Move to cl-macs.el and rename to cl--sm-macroexpand. + (cl-member): Remove old alias. + + * emacs-lisp/cl-extra.el (cl-map-keymap, cl-copy-tree) + (cl-not-hash-table, cl-builtin-gethash, cl-builtin-remhash) + (cl-builtin-clrhash, cl-builtin-maphash, cl-gethash, cl-puthash) + (cl-remhash, cl-clrhash, cl-maphash, cl-make-hash-table) + (cl-hash-table-p, cl-hash-table-count): Move to cl.el. + (cl-macroexpand-cmacs): Remove var. + (cl-macroexpand-all, cl-macroexpand-body): Remove funs. + Use macroexpand-all instead. + +2012-06-07 Stefan Monnier + * emacs-lisp/macroexp.el (macroexp-progn, macroexp-let*, macroexp-if) (macroexp-let², macroexp--const-symbol-p, macroexp-const-p) (macroexp-copyable-p): New functions and macros. === modified file 'lisp/emacs-lisp/cl-extra.el' --- lisp/emacs-lisp/cl-extra.el 2012-06-04 01:05:17 +0000 +++ lisp/emacs-lisp/cl-extra.el 2012-06-07 19:48:22 +0000 @@ -221,10 +221,6 @@ \n(fn PREDICATE SEQ...)" (not (apply 'cl-every cl-pred cl-seq cl-rest))) -;;; Support for `cl-loop'. -;;;###autoload -(defalias 'cl-map-keymap 'map-keymap) - ;;;###autoload (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) (or cl-base @@ -460,7 +456,7 @@ "Return a copy of random-state STATE, or of the internal state if omitted. If STATE is t, return a new state object seeded from the time of day." (cond ((null state) (cl-make-random-state cl--random-state)) - ((vectorp state) (cl-copy-tree state t)) + ((vectorp state) (copy-tree state t)) ((integerp state) (vector 'cl-random-state-tag -1 30 state)) (t (cl-make-random-state (cl-random-time))))) @@ -585,9 +581,6 @@ (setq list (cdr list))) (if (numberp sublist) (equal sublist list) (eq sublist list))) -(defalias 'cl-copy-tree 'copy-tree) - - ;;; Property lists. ;;;###autoload @@ -637,36 +630,6 @@ (progn (setplist sym (cdr (cdr plist))) t) (cl-do-remf plist tag)))) -;;; Hash tables. -;; This is just kept for compatibility with code byte-compiled by Emacs-20. - -;; No idea if this might still be needed. -(defun cl-not-hash-table (x &optional y &rest z) - (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x)))) - -(defvar cl-builtin-gethash (symbol-function 'gethash)) -(defvar cl-builtin-remhash (symbol-function 'remhash)) -(defvar cl-builtin-clrhash (symbol-function 'clrhash)) -(defvar cl-builtin-maphash (symbol-function 'maphash)) - -;;;###autoload -(defalias 'cl-gethash 'gethash) -;;;###autoload -(defalias 'cl-puthash 'puthash) -;;;###autoload -(defalias 'cl-remhash 'remhash) -;;;###autoload -(defalias 'cl-clrhash 'clrhash) -;;;###autoload -(defalias 'cl-maphash 'maphash) -;; These three actually didn't exist in Emacs-20. -;;;###autoload -(defalias 'cl-make-hash-table 'make-hash-table) -;;;###autoload -(defalias 'cl-hash-table-p 'hash-table-p) -;;;###autoload -(defalias 'cl-hash-table-count 'hash-table-count) - ;;; Some debugging aids. (defun cl-prettyprint (form) @@ -710,93 +673,13 @@ (forward-char 1)))) (forward-sexp))) -(defvar cl-macroexpand-cmacs nil) -(defvar cl-closure-vars nil) - -;;;###autoload -(defun cl-macroexpand-all (form &optional env) - "Expand all macro calls through a Lisp FORM. -This also does some trivial optimizations to make the form prettier." - (while (or (not (eq form (setq form (macroexpand form env)))) - (and cl-macroexpand-cmacs - (not (eq form (setq form (cl-compiler-macroexpand form))))))) - (cond ((not (consp form)) form) - ((memq (car form) '(let let*)) - (if (null (nth 1 form)) - (cl-macroexpand-all (cons 'progn (cddr form)) env) - (let ((letf nil) (res nil) (lets (cadr form))) - (while lets - (push (if (consp (car lets)) - (let ((exp (cl-macroexpand-all (caar lets) env))) - (or (symbolp exp) (setq letf t)) - (cons exp (cl-macroexpand-body (cdar lets) env))) - (let ((exp (cl-macroexpand-all (car lets) env))) - (if (symbolp exp) exp - (setq letf t) (list exp nil)))) res) - (setq lets (cdr lets))) - (cl-list* (if letf (if (eq (car form) 'let) 'cl-letf 'cl-letf*) (car form)) - (nreverse res) (cl-macroexpand-body (cddr form) env))))) - ((eq (car form) 'cond) - (cons (car form) - (mapcar (function (lambda (x) (cl-macroexpand-body x env))) - (cdr form)))) - ((eq (car form) 'condition-case) - (cl-list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env) - (mapcar (function - (lambda (x) - (cons (car x) (cl-macroexpand-body (cdr x) env)))) - (cl-cdddr form)))) - ((memq (car form) '(quote function)) - (if (eq (car-safe (nth 1 form)) 'lambda) - (let ((body (cl-macroexpand-body (cl-cddadr form) env))) - (if (and cl-closure-vars (eq (car form) 'function) - (cl-expr-contains-any body cl-closure-vars)) - (let* ((new (mapcar 'cl-gensym cl-closure-vars)) - (sub (cl-pairlis cl-closure-vars new)) (decls nil)) - (while (or (stringp (car body)) - (eq (car-safe (car body)) 'interactive)) - (push (list 'quote (pop body)) decls)) - (put (car (last cl-closure-vars)) 'used t) - `(list 'lambda '(&rest --cl-rest--) - ,@(cl-sublis sub (nreverse decls)) - (list 'apply - (list 'quote - #'(lambda ,(append new (cl-cadadr form)) - ,@(cl-sublis sub body))) - ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) - cl-closure-vars) - '((quote --cl-rest--)))))) - (list (car form) (cl-list* 'lambda (cl-cadadr form) body)))) - (let ((found (assq (cadr form) env))) - (if (and found (ignore-errors - (eq (cadr (cl-caddr found)) 'cl-labels-args))) - (cl-macroexpand-all (cadr (cl-caddr (cl-cadddr found))) env) - form)))) - ((memq (car form) '(defun defmacro)) - (cl-list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) - ((and (eq (car form) 'progn) (not (cddr form))) - (cl-macroexpand-all (nth 1 form) env)) - ((eq (car form) 'setq) - (let* ((args (cl-macroexpand-body (cdr form) env)) (p args)) - (while (and p (symbolp (car p))) (setq p (cddr p))) - (if p (cl-macroexpand-all (cons 'cl-setf args)) (cons 'setq args)))) - ((consp (car form)) - (cl-macroexpand-all (cl-list* 'funcall - (list 'function (car form)) - (cdr form)) - env)) - (t (cons (car form) (cl-macroexpand-body (cdr form) env))))) - -(defun cl-macroexpand-body (body &optional env) - (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) - ;;;###autoload (defun cl-prettyexpand (form &optional full) (message "Expanding...") (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) (byte-compile-macro-environment nil)) - (setq form (cl-macroexpand-all form - (and (not full) '((cl-block) (cl-eval-when))))) + (setq form (macroexpand-all form + (and (not full) '((cl-block) (cl-eval-when))))) (message "Formatting...") (prog1 (cl-prettyprint form) (message "")))) === modified file 'lisp/emacs-lisp/cl-lib.el' --- lisp/emacs-lisp/cl-lib.el 2012-06-05 15:41:12 +0000 +++ lisp/emacs-lisp/cl-lib.el 2012-06-07 19:48:22 +0000 @@ -267,29 +267,6 @@ one value." (nth n expression)) -;;; Macros. - -(defvar cl-macro-environment) -(defvar cl-old-macroexpand (prog1 (symbol-function 'macroexpand) - (defalias 'macroexpand 'cl-macroexpand))) - -(defun cl-macroexpand (cl-macro &optional cl-env) - "Return result of expanding macros at top level of FORM. -If FORM is not a macro call, it is returned unchanged. -Otherwise, the macro is expanded and the expansion is considered -in place of FORM. When a non-macro-call results, it is returned. - -The second optional arg ENVIRONMENT specifies an environment of macro -definitions to shadow the loaded ones for use in file byte-compilation. -\n(fn FORM &optional ENVIRONMENT)" - (let ((cl-macro-environment cl-env)) - (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env)) - (and (symbolp cl-macro) - (cdr (assq (symbol-name cl-macro) cl-env)))) - (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) - cl-macro)) - - ;;; Declarations. (defvar cl-compiling-file nil) @@ -600,8 +577,6 @@ (while (and list (not (equal item (car list)))) (setq list (cdr list))) list) -(defalias 'cl-member 'memq) ; for compatibility with old CL package - ;; Autoloaded, but we have not loaded cl-loaddefs yet. (declare-function cl-floor "cl-extra" (x &optional y)) (declare-function cl-ceiling "cl-extra" (x &optional y)) === modified file 'lisp/emacs-lisp/cl-loaddefs.el' --- lisp/emacs-lisp/cl-loaddefs.el 2012-06-07 19:25:48 +0000 +++ lisp/emacs-lisp/cl-loaddefs.el 2012-06-07 19:48:22 +0000 @@ -3,16 +3,15 @@ ;;; Code: -;;;### (autoloads (cl-prettyexpand cl-macroexpand-all cl-remprop -;;;;;; cl-do-remf cl-set-getf cl-getf cl-get cl-tailp cl-list-length -;;;;;; cl-nreconc cl-revappend cl-concatenate cl-subseq cl-float-limits -;;;;;; cl-random-state-p cl-make-random-state cl-random cl-signum -;;;;;; cl-rem cl-mod cl-round cl-truncate cl-ceiling cl-floor cl-isqrt -;;;;;; cl-lcm cl-gcd cl-progv-before cl-set-frame-visible-p cl-map-overlays -;;;;;; cl-map-intervals cl-map-keymap-recursively cl-notevery cl-notany -;;;;;; cl-every cl-some cl-mapcon cl-mapcan cl-mapl cl-maplist cl-map -;;;;;; cl-mapcar-many cl-equalp cl-coerce) "cl-extra" "cl-extra.el" -;;;;;; "acc0000b09b27fb51f5ba23a4b9254e2") +;;;### (autoloads (cl-prettyexpand cl-remprop cl-do-remf cl-set-getf +;;;;;; cl-getf cl-get cl-tailp cl-list-length cl-nreconc cl-revappend +;;;;;; cl-concatenate cl-subseq cl-float-limits cl-random-state-p +;;;;;; cl-make-random-state cl-random cl-signum cl-rem cl-mod cl-round +;;;;;; cl-truncate cl-ceiling cl-floor cl-isqrt cl-lcm cl-gcd cl-progv-before +;;;;;; cl-set-frame-visible-p cl-map-overlays cl-map-intervals cl-map-keymap-recursively +;;;;;; cl-notevery cl-notany cl-every cl-some cl-mapcon cl-mapcan +;;;;;; cl-mapl cl-maplist cl-map cl-mapcar-many cl-equalp cl-coerce) +;;;;;; "cl-extra" "cl-extra.el" "fecce2e361fd06364d2ffd8c0d482cd0") ;;; Generated autoloads from cl-extra.el (autoload 'cl-coerce "cl-extra" "\ @@ -83,8 +82,6 @@ \(fn PREDICATE SEQ...)" nil nil) -(defalias 'cl-map-keymap 'map-keymap) - (autoload 'cl-map-keymap-recursively "cl-extra" "\ @@ -248,28 +245,6 @@ \(fn SYMBOL PROPNAME)" nil nil) -(defalias 'cl-gethash 'gethash) - -(defalias 'cl-puthash 'puthash) - -(defalias 'cl-remhash 'remhash) - -(defalias 'cl-clrhash 'clrhash) - -(defalias 'cl-maphash 'maphash) - -(defalias 'cl-make-hash-table 'make-hash-table) - -(defalias 'cl-hash-table-p 'hash-table-p) - -(defalias 'cl-hash-table-count 'hash-table-count) - -(autoload 'cl-macroexpand-all "cl-extra" "\ -Expand all macro calls through a Lisp FORM. -This also does some trivial optimizations to make the form prettier. - -\(fn FORM &optional ENV)" nil nil) - (autoload 'cl-prettyexpand "cl-extra" "\ @@ -289,7 +264,7 @@ ;;;;;; cl-return cl-block cl-etypecase cl-typecase cl-ecase cl-case ;;;;;; cl-load-time-value cl-eval-when cl-destructuring-bind cl-function ;;;;;; cl-defmacro cl-defun cl-gentemp cl-gensym) "cl-macs" "cl-macs.el" -;;;;;; "25086e27342ec0990f35f1748a5b7b4e") +;;;;;; "c1e8e5391e374630452ab3d78e527086") ;;; Generated autoloads from cl-macs.el (autoload 'cl-gensym "cl-macs" "\ === modified file 'lisp/emacs-lisp/cl-macs.el' --- lisp/emacs-lisp/cl-macs.el 2012-06-07 19:25:48 +0000 +++ lisp/emacs-lisp/cl-macs.el 2012-06-07 19:48:22 +0000 @@ -310,11 +310,6 @@ (defconst cl-lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) -(defvar cl-macro-environment nil - "Keep the list of currently active macros. -It is a list of elements of the form either: -- (SYMBOL . FUNCTION) where FUNCTION is the macro expansion function. -- (SYMBOL-NAME . EXPANSION) where SYMBOL-NAME is the name of a symbol macro.") (defvar cl-bind-block) (defvar cl-bind-defs) (defvar cl-bind-enquote) (defvar cl-bind-inits) (defvar cl-bind-lets) (defvar cl-bind-forms) @@ -367,9 +362,10 @@ (if (setq cl-bind-enquote (memq '&cl-quote args)) (setq args (delq '&cl-quote args))) (if (memq '&whole args) (error "&whole not currently implemented")) - (let* ((p (memq '&environment args)) (v (cadr p))) + (let* ((p (memq '&environment args)) (v (cadr p)) + (env-exp 'macroexpand-all-environment)) (if p (setq args (nconc (delq (car p) (delq v args)) - (list '&aux (list v 'cl-macro-environment)))))) + (list '&aux (list v env-exp)))))) (while (and args (symbolp (car args)) (not (memq (car args) '(nil &rest &body &key &aux))) (not (and (eq (car args) '&optional) @@ -1630,7 +1626,7 @@ (lambda (x) (if (or (and (fboundp (car x)) (eq (car-safe (symbol-function (car x))) 'macro)) - (cdr (assq (car x) cl-macro-environment))) + (cdr (assq (car x) macroexpand-all-environment))) (error "Use `cl-labels', not `cl-flet', to rebind macro names")) (let ((func `(cl-function (lambda ,(cadr x) @@ -1657,7 +1653,7 @@ \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug cl-flet)) - (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) + (let ((vars nil) (sets nil) (newenv macroexpand-all-environment)) (while bindings ;; Use `cl-gensym' rather than `make-symbol'. It's important that ;; (not (eq (symbol-name var1) (symbol-name var2))) because these @@ -1670,9 +1666,8 @@ `(lambda (&rest cl-labels-args) (cl-list* 'funcall ',var cl-labels-args))) - cl-macro-environment))) - (cl-macroexpand-all `(cl-lexical-let ,vars (setq ,@sets) ,@body) - cl-macro-environment))) + newenv))) + (macroexpand-all `(cl-lexical-let ,vars (setq ,@sets) ,@body) newenv))) ;; The following ought to have a better definition for use with newer ;; byte compilers. @@ -1693,9 +1688,42 @@ (let* ((name (caar bindings)) (res (cl--transform-lambda (cdar bindings) name))) (eval (car res)) - (cl-macroexpand-all (cons 'progn body) - (cons (cons name `(lambda ,@(cdr res))) - cl-macro-environment)))))) + (macroexpand-all (cons 'progn body) + (cons (cons name `(lambda ,@(cdr res))) + macroexpand-all-environment)))))) + +(defconst cl--old-macroexpand + (if (and (boundp 'cl--old-macroexpand) + (eq (symbol-function 'macroexpand) + #'cl--sm-macroexpand)) + cl--old-macroexpand + (symbol-function 'macroexpand))) + +(defun cl--sm-macroexpand (cl-macro &optional cl-env) + "Special macro expander used inside `cl-symbol-macrolet'. +This function replaces `macroexpand' during macro expansion +of `cl-symbol-macrolet', and does the same thing as `macroexpand' +except that it additionally expands symbol macros." + (let ((macroexpand-all-environment cl-env)) + (while + (progn + (setq cl-macro (funcall cl--old-macroexpand cl-macro cl-env)) + (cond + ((symbolp cl-macro) + ;; Perform symbol-macro expansion. + (when (cdr (assq (symbol-name cl-macro) cl-env)) + (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env))))) + ((eq 'setq (car-safe cl-macro)) + ;; Convert setq to cl-setf if required by symbol-macro expansion. + (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f cl-env)) + (cdr cl-macro))) + (p args)) + (while (and p (symbolp (car p))) (setq p (cddr p))) + (if p (setq cl-macro (cons 'cl-setf args)) + (setq cl-macro (cons 'setq args)) + ;; Don't loop further. + nil)))))) + cl-macro)) ;;;###autoload (defmacro cl-symbol-macrolet (bindings &rest body) @@ -1705,16 +1733,71 @@ \(fn ((NAME EXPANSION) ...) FORM...)" (declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body))) - (if (cdr bindings) + (cond + ((cdr bindings) `(cl-symbol-macrolet (,(car bindings)) - (cl-symbol-macrolet ,(cdr bindings) ,@body)) - (if (null bindings) (cons 'progn body) - (cl-macroexpand-all (cons 'progn body) + (cl-symbol-macrolet ,(cdr bindings) ,@body))) + ((null bindings) (macroexp-progn body)) + (t + (let ((previous-macroexpand (symbol-function 'macroexpand))) + (unwind-protect + (progn + (fset 'macroexpand #'cl--sm-macroexpand) + ;; FIXME: For N bindings, this will traverse `body' N times! + (macroexpand-all (cons 'progn body) (cons (list (symbol-name (caar bindings)) (cl-cadar bindings)) - cl-macro-environment))))) + macroexpand-all-environment))) + (fset 'macroexpand previous-macroexpand)))))) (defvar cl-closure-vars nil) +(defvar cl--function-convert-cache nil) + +(defun cl--function-convert (f) + "Special macro-expander for special cases of (function F). +The two cases that are handled are: +- closure-conversion of lambda expressions for `cl-lexical-let'. +- renaming of F when it's a function defined via `cl-labels'." + (cond + ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked + ;; *after* handling `function', but we want to stop macroexpansion from + ;; being applied infinitely, so we use a cache to return the exact `form' + ;; being expanded even though we don't receive it. + ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache)) + ((eq (car-safe f) 'lambda) + (let ((body (mapcar (lambda (f) + (macroexpand-all f macroexpand-all-environment)) + (cddr f)))) + (if (and cl-closure-vars + (cl--expr-contains-any body cl-closure-vars)) + (let* ((new (mapcar 'cl-gensym cl-closure-vars)) + (sub (cl-pairlis cl-closure-vars new)) (decls nil)) + (while (or (stringp (car body)) + (eq (car-safe (car body)) 'interactive)) + (push (list 'quote (pop body)) decls)) + (put (car (last cl-closure-vars)) 'used t) + `(list 'lambda '(&rest --cl-rest--) + ,@(cl-sublis sub (nreverse decls)) + (list 'apply + (list 'quote + #'(lambda ,(append new (cadr f)) + ,@(cl-sublis sub body))) + ,@(nconc (mapcar (lambda (x) `(list 'quote ,x)) + cl-closure-vars) + '((quote --cl-rest--)))))) + (let* ((newf `(lambda ,(cadr f) ,@body)) + (res `(function ,newf))) + (setq cl--function-convert-cache (cons newf res)) + res)))) + (t + (let ((found (assq f macroexpand-all-environment))) + (if (and found (ignore-errors + (eq (cadr (cl-caddr found)) 'cl-labels-args))) + (cadr (cl-caddr (cl-cadddr found))) + (let ((res `(function ,f))) + (setq cl--function-convert-cache (cons f res)) + res)))))) + ;;;###autoload (defmacro cl-lexical-let (bindings &rest body) "Like `let', but lexically scoped. @@ -1732,13 +1815,14 @@ (list (car x) (cadr x) (car cl-closure-vars)))) bindings)) (ebody - (cl-macroexpand-all + (macroexpand-all `(cl-symbol-macrolet ,(mapcar (lambda (x) `(,(car x) (symbol-value ,(cl-caddr x)))) vars) ,@body) - cl-macro-environment))) + (cons (cons 'function #'cl--function-convert) + macroexpand-all-environment)))) (if (not (get (car (last cl-closure-vars)) 'used)) ;; Turn (let ((foo (cl-gensym))) ;; (set foo ) ...(symbol-value foo)...) @@ -2132,7 +2216,7 @@ ;; This is useful when you have control over the PLACE but not over ;; the VALUE, as is the case in define-minor-mode's :variable. (cl-define-setf-expander eq (place val) - (let ((method (cl-get-setf-method place cl-macro-environment)) + (let ((method (cl-get-setf-method place macroexpand-all-environment)) (val-temp (make-symbol "--eq-val--")) (store-temp (make-symbol "--eq-store--"))) (list (append (nth 0 method) (list val-temp)) @@ -2146,14 +2230,14 @@ ;;; More complex setf-methods. ;; These should take &environment arguments, but since full arglists aren't ;; available while compiling cl-macs, we fake it by referring to the global -;; variable cl-macro-environment directly. +;; variable macroexpand-all-environment directly. (cl-define-setf-expander apply (func arg1 &rest rest) (or (and (memq (car-safe func) '(quote function cl-function)) (symbolp (car-safe (cdr-safe func)))) (error "First arg to apply in cl-setf is not (function SYM): %s" func)) (let* ((form (cons (nth 1 func) (cons arg1 rest))) - (method (cl-get-setf-method form cl-macro-environment))) + (method (cl-get-setf-method form macroexpand-all-environment))) (list (car method) (nth 1 method) (nth 2 method) (cl-setf-make-apply (nth 3 method) (cadr func) (car method)) (cl-setf-make-apply (nth 4 method) (cadr func) (car method))))) @@ -2166,7 +2250,7 @@ `(apply ',(car form) ,@(cdr form)))) (cl-define-setf-expander nthcdr (n place) - (let ((method (cl-get-setf-method place cl-macro-environment)) + (let ((method (cl-get-setf-method place macroexpand-all-environment)) (n-temp (make-symbol "--cl-nthcdr-n--")) (store-temp (make-symbol "--cl-nthcdr-store--"))) (list (cons n-temp (car method)) @@ -2179,7 +2263,7 @@ `(nthcdr ,n-temp ,(nth 4 method))))) (cl-define-setf-expander cl-getf (place tag &optional def) - (let ((method (cl-get-setf-method place cl-macro-environment)) + (let ((method (cl-get-setf-method place macroexpand-all-environment)) (tag-temp (make-symbol "--cl-getf-tag--")) (def-temp (make-symbol "--cl-getf-def--")) (store-temp (make-symbol "--cl-getf-store--"))) @@ -2192,7 +2276,7 @@ `(cl-getf ,(nth 4 method) ,tag-temp ,def-temp)))) (cl-define-setf-expander substring (place from &optional to) - (let ((method (cl-get-setf-method place cl-macro-environment)) + (let ((method (cl-get-setf-method place macroexpand-all-environment)) (from-temp (make-symbol "--cl-substring-from--")) (to-temp (make-symbol "--cl-substring-to--")) (store-temp (make-symbol "--cl-substring-store--"))) @@ -2220,7 +2304,7 @@ (method (get func 'setf-method)) (case-fold-search nil)) (or (and method - (let ((cl-macro-environment env)) + (let ((macroexpand-all-environment env)) (setq method (apply method (cdr place)))) (if (and (consp method) (= (length method) 5)) method @@ -2240,7 +2324,7 @@ (cl-get-setf-method place env))))) (defun cl-setf-do-modify (place opt-expr) - (let* ((method (cl-get-setf-method place cl-macro-environment)) + (let* ((method (cl-get-setf-method place macroexpand-all-environment)) (temps (car method)) (values (nth 1 method)) (lets nil) (subs nil) (optimize (and (not (eq opt-expr 'no-opt)) === modified file 'lisp/emacs-lisp/cl.el' --- lisp/emacs-lisp/cl.el 2012-06-07 19:25:48 +0000 +++ lisp/emacs-lisp/cl.el 2012-06-07 19:48:22 +0000 @@ -330,5 +330,37 @@ (if (get new prop) (put fun prop (get new prop)))))) +;;; Additional compatibility code +;; For names that were clean but really aren't needed any more. + +(defalias 'cl-macroexpand 'macroexpand) +(defvaralias 'cl-macro-environment 'macroexpand-all-environment) +(defalias 'cl-macroexpand-all 'macroexpand-all) + +;;; Hash tables. +;; This is just kept for compatibility with code byte-compiled by Emacs-20. + +;; No idea if this might still be needed. +(defun cl-not-hash-table (x &optional y &rest z) + (signal 'wrong-type-argument (list 'cl-hash-table-p (or y x)))) + +(defvar cl-builtin-gethash (symbol-function 'gethash)) +(defvar cl-builtin-remhash (symbol-function 'remhash)) +(defvar cl-builtin-clrhash (symbol-function 'clrhash)) +(defvar cl-builtin-maphash (symbol-function 'maphash)) + +(defalias 'cl-map-keymap 'map-keymap) +(defalias 'cl-copy-tree 'copy-tree) +(defalias 'cl-gethash 'gethash) +(defalias 'cl-puthash 'puthash) +(defalias 'cl-remhash 'remhash) +(defalias 'cl-clrhash 'clrhash) +(defalias 'cl-maphash 'maphash) +(defalias 'cl-make-hash-table 'make-hash-table) +(defalias 'cl-hash-table-p 'hash-table-p) +(defalias 'cl-hash-table-count 'hash-table-count) + +;; FIXME: More candidates: define-modify-macro, define-setf-expander, lexical-let. + (provide 'cl) ;;; cl.el ends here ------------------------------------------------------------ revno: 108513 committer: Stefan Monnier branch nick: trunk timestamp: Thu 2012-06-07 15:25:48 -0400 message: Cleanup cl-macs namespace. Add macro helpers in macroexp.el. * emacs-lisp/macroexp.el (macroexp-progn, macroexp-let*, macroexp-if) (macroexp-let², macroexp--const-symbol-p, macroexp-const-p) (macroexp-copyable-p): New functions and macros. * emacs-lisp/edebug.el (edebug-unwrap): * emacs-lisp/disass.el (disassemble-internal): Use macroexp-progn. * emacs-lisp/pcase.el: Use macroexp-let*, macroexp-if, ... (pcase--let*): Remove. * emacs-lisp/bytecomp.el (byte-compile-const-symbol-p) (byte-compile-constp): Remove. Use macroexp--const-symbol-p and macroexp-const-p instead. * emacs-lisp/byte-opt.el: Use macroexp-const-p and macroexp-progn. * emacs-lisp/cl-macs.el: Clean up the name space by using "cl--" instead of "cl-" for internal definitions. Use macroexp-const-p. (cl-old-bc-file-form): Remove var. (cl-const-exprs-p): Remove fun. (cl-labels, cl-macrolet): Use backquote. (cl-lexical-let): Use cl-symbol-macrolet. Don't use cl-defun-expander. (cl-defun-expander, cl-byte-compile-compiler-macro): Remove fun. (cl-define-setf-expander): Rename from cl-define-setf-method. * emacs-lisp/cl.el: Adjust alias for define-setf-method. * international/mule-cmds.el: Don't require CL. (view-hello-file): Don't use `letf'. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-07 16:35:00 +0000 +++ lisp/ChangeLog 2012-06-07 19:25:48 +0000 @@ -1,5 +1,32 @@ 2012-06-07 Stefan Monnier + * emacs-lisp/macroexp.el (macroexp-progn, macroexp-let*, macroexp-if) + (macroexp-let², macroexp--const-symbol-p, macroexp-const-p) + (macroexp-copyable-p): New functions and macros. + * emacs-lisp/edebug.el (edebug-unwrap): + * emacs-lisp/disass.el (disassemble-internal): Use macroexp-progn. + * emacs-lisp/pcase.el: Use macroexp-let*, macroexp-if, ... + (pcase--let*): Remove. + * emacs-lisp/bytecomp.el (byte-compile-const-symbol-p) + (byte-compile-constp): Remove. Use macroexp--const-symbol-p and + macroexp-const-p instead. + * emacs-lisp/byte-opt.el: Use macroexp-const-p and macroexp-progn. + + * emacs-lisp/cl-macs.el: Clean up the name space by using "cl--" + instead of "cl-" for internal definitions. Use macroexp-const-p. + (cl-old-bc-file-form): Remove var. + (cl-const-exprs-p): Remove fun. + (cl-labels, cl-macrolet): Use backquote. + (cl-lexical-let): Use cl-symbol-macrolet. Don't use cl-defun-expander. + (cl-defun-expander, cl-byte-compile-compiler-macro): Remove fun. + (cl-define-setf-expander): Rename from cl-define-setf-method. + * emacs-lisp/cl.el: Adjust alias for define-setf-method. + + * international/mule-cmds.el: Don't require CL. + (view-hello-file): Don't use `letf'. + +2012-06-07 Stefan Monnier + * tmm.el (tmm-prompt): Use string-prefix-p. (tmm-completion-delete-prompt): Don't affect current-buffer outside. (tmm-add-prompt): Use minibuffer-completion-help. === modified file 'lisp/emacs-lisp/byte-opt.el' --- lisp/emacs-lisp/byte-opt.el 2012-06-05 15:41:12 +0000 +++ lisp/emacs-lisp/byte-opt.el 2012-06-07 19:25:48 +0000 @@ -184,6 +184,7 @@ (require 'bytecomp) (eval-when-compile (require 'cl)) +(require 'macroexp) (defun byte-compile-log-lap-1 (format &rest args) ;; Newer byte codes for stack-ref make the slot 0 non-nil again. @@ -434,11 +435,9 @@ clause)) (cdr form)))) ((eq fn 'progn) - ;; as an extra added bonus, this simplifies (progn ) --> + ;; As an extra added bonus, this simplifies (progn ) --> . (if (cdr (cdr form)) - (progn - (setq tmp (byte-optimize-body (cdr form) for-effect)) - (if (cdr tmp) (cons 'progn tmp) (car tmp))) + (macroexp-progn (byte-optimize-body (cdr form) for-effect)) (byte-optimize-form (nth 1 form) for-effect))) ((eq fn 'prog1) (if (cdr (cdr form)) @@ -577,10 +576,10 @@ (cons fn args))))))) (defun byte-optimize-all-constp (list) - "Non-nil if all elements of LIST satisfy `byte-compile-constp'." + "Non-nil if all elements of LIST satisfy `macroexp-const-p" (let ((constant t)) (while (and list constant) - (unless (byte-compile-constp (car list)) + (unless (macroexp-const-p (car list)) (setq constant nil)) (setq list (cdr list))) constant)) @@ -870,8 +869,8 @@ (defun byte-optimize-binary-predicate (form) - (if (byte-compile-constp (nth 1 form)) - (if (byte-compile-constp (nth 2 form)) + (if (macroexp-const-p (nth 1 form)) + (if (macroexp-const-p (nth 2 form)) (condition-case () (list 'quote (eval form)) (error form)) @@ -883,7 +882,7 @@ (let ((ok t) (rest (cdr form))) (while (and rest ok) - (setq ok (byte-compile-constp (car rest)) + (setq ok (macroexp-const-p (car rest)) rest (cdr rest))) (if ok (condition-case () @@ -949,7 +948,7 @@ (defun byte-optimize-quote (form) (if (or (consp (nth 1 form)) (and (symbolp (nth 1 form)) - (not (byte-compile-const-symbol-p form)))) + (not (macroexp--const-symbol-p form)))) form (nth 1 form))) @@ -1586,13 +1585,13 @@ (not (eq (car lap0) 'byte-constant))) nil (setq keep-going t) - (if (memq (car lap0) '(byte-constant byte-dup)) - (progn - (setq tmp (if (or (not tmp) - (byte-compile-const-symbol-p - (car (cdr lap0)))) - (cdr lap0) - (byte-compile-get-constant t))) + (if (memq (car lap0) '(byte-constant byte-dup)) + (progn + (setq tmp (if (or (not tmp) + (macroexp--const-symbol-p + (car (cdr lap0)))) + (cdr lap0) + (byte-compile-get-constant t))) (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" lap0 lap1 lap2 lap0 lap1 (cons (car lap0) tmp)) === modified file 'lisp/emacs-lisp/bytecomp.el' --- lisp/emacs-lisp/bytecomp.el 2012-06-05 15:41:12 +0000 +++ lisp/emacs-lisp/bytecomp.el 2012-06-07 19:25:48 +0000 @@ -1464,29 +1464,6 @@ nil) -(defsubst byte-compile-const-symbol-p (symbol &optional any-value) - "Non-nil if SYMBOL is constant. -If ANY-VALUE is nil, only return non-nil if the value of the symbol is the -symbol itself." - (or (memq symbol '(nil t)) - (keywordp symbol) - (if any-value - (or (memq symbol byte-compile-const-variables) - ;; FIXME: We should provide a less intrusive way to find out - ;; if a variable is "constant". - (and (boundp symbol) - (condition-case nil - (progn (set symbol (symbol-value symbol)) nil) - (setting-constant t))))))) - -(defmacro byte-compile-constp (form) - "Return non-nil if FORM is a constant." - `(cond ((consp ,form) (or (eq (car ,form) 'quote) - (and (eq (car ,form) 'function) - (symbolp (cadr ,form))))) - ((not (symbolp ,form))) - ((byte-compile-const-symbol-p ,form)))) - ;; Dynamically bound in byte-compile-from-buffer. ;; NB also used in cl.el and cl-macs.el. (defvar byte-compile--outbuffer) @@ -2204,7 +2181,7 @@ (put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) (defun byte-compile-file-form-autoload (form) (and (let ((form form)) - (while (if (setq form (cdr form)) (byte-compile-constp (car form)))) + (while (if (setq form (cdr form)) (macroexp-const-p (car form)))) (null form)) ;Constants only (eval (nth 5 form)) ;Macro (eval form)) ;Define the autoload. @@ -2510,7 +2487,7 @@ (when (symbolp arg) (byte-compile-set-symbol-position arg)) (cond ((or (not (symbolp arg)) - (byte-compile-const-symbol-p arg t)) + (macroexp--const-symbol-p arg t)) (error "Invalid lambda variable %s" arg)) ((eq arg '&rest) (unless (cdr list) @@ -2779,7 +2756,7 @@ (if (if (eq (car (car rest)) 'byte-constant) (or (consp tmp) (and (symbolp tmp) - (not (byte-compile-const-symbol-p tmp))))) + (not (macroexp--const-symbol-p tmp))))) (if maycall (setq body (cons (list 'quote tmp) body))) (setq body (cons tmp body)))) @@ -2850,7 +2827,7 @@ (let ((byte-compile--for-effect for-effect)) (cond ((not (consp form)) - (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) + (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) (when (symbolp form) (byte-compile-set-symbol-position form)) (byte-compile-constant form)) @@ -2863,7 +2840,7 @@ ((symbolp (car form)) (let* ((fn (car form)) (handler (get fn 'byte-compile))) - (when (byte-compile-const-symbol-p fn) + (when (macroexp--const-symbol-p fn) (byte-compile-warn "`%s' called as a function" fn)) (and (byte-compile-warning-enabled-p 'interactive-only) (memq fn byte-compile-interactive-only-functions) @@ -2997,7 +2974,7 @@ "Do various error checks before a use of the variable VAR." (when (symbolp var) (byte-compile-set-symbol-position var)) - (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var)) + (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) (when (byte-compile-warning-enabled-p 'constants) (byte-compile-warn (if (eq access-type 'let-bind) "attempt to let-bind %s `%s`" @@ -3568,7 +3545,7 @@ (byte-compile-form (cons 'progn (nreverse setters)))) (let ((var (car form))) (and (or (not (symbolp var)) - (byte-compile-const-symbol-p var t)) + (macroexp--const-symbol-p var t)) (byte-compile-warning-enabled-p 'constants) (byte-compile-warn "variable assignment to %s `%s'" @@ -4117,8 +4094,8 @@ (defun byte-compile-autoload (form) (byte-compile-set-symbol-position 'autoload) - (and (byte-compile-constp (nth 1 form)) - (byte-compile-constp (nth 5 form)) + (and (macroexp-const-p (nth 1 form)) + (macroexp-const-p (nth 5 form)) (eval (nth 5 form)) ; macro-p (not (fboundp (eval (nth 1 form)))) (byte-compile-warn === modified file 'lisp/emacs-lisp/cl-loaddefs.el' --- lisp/emacs-lisp/cl-loaddefs.el 2012-06-05 16:43:43 +0000 +++ lisp/emacs-lisp/cl-loaddefs.el 2012-06-07 19:25:48 +0000 @@ -281,7 +281,7 @@ ;;;;;; cl-assert cl-check-type cl-typep cl-deftype cl-struct-setf-expander ;;;;;; cl-defstruct cl-define-modify-macro cl-callf2 cl-callf cl-letf* ;;;;;; cl-letf cl-rotatef cl-shiftf cl-remf cl-do-pop cl-psetf cl-setf -;;;;;; cl-get-setf-method cl-defsetf cl-define-setf-method cl-declare +;;;;;; cl-get-setf-method cl-defsetf cl-define-setf-expander cl-declare ;;;;;; cl-the cl-locally cl-multiple-value-setq cl-multiple-value-bind ;;;;;; cl-lexical-let* cl-lexical-let cl-symbol-macrolet cl-macrolet ;;;;;; cl-labels cl-flet cl-progv cl-psetq cl-do-all-symbols cl-do-symbols @@ -289,7 +289,7 @@ ;;;;;; cl-return cl-block cl-etypecase cl-typecase cl-ecase cl-case ;;;;;; cl-load-time-value cl-eval-when cl-destructuring-bind cl-function ;;;;;; cl-defmacro cl-defun cl-gentemp cl-gensym) "cl-macs" "cl-macs.el" -;;;;;; "f3973150add70d26cadb8530147dfc99") +;;;;;; "25086e27342ec0990f35f1748a5b7b4e") ;;; Generated autoloads from cl-macs.el (autoload 'cl-gensym "cl-macs" "\ @@ -611,7 +611,7 @@ \(fn &rest SPECS)" nil t) -(autoload 'cl-define-setf-method "cl-macs" "\ +(autoload 'cl-define-setf-expander "cl-macs" "\ Define a `cl-setf' method. This method shows how to handle `cl-setf's to places of the form (NAME ARGS...). The argument forms ARGS are bound according to ARGLIST, as if NAME were @@ -624,7 +624,7 @@ (autoload 'cl-defsetf "cl-macs" "\ Define a `cl-setf' method. -This macro is an easy-to-use substitute for `cl-define-setf-method' that works +This macro is an easy-to-use substitute for `cl-define-setf-expander' that works well for simple place forms. In the simple `cl-defsetf' form, `cl-setf's of the form (cl-setf (NAME ARGS...) VAL) are transformed to function or macro calls of the form (FUNC ARGS... VAL). Example: === modified file 'lisp/emacs-lisp/cl-macs.el' --- lisp/emacs-lisp/cl-macs.el 2012-06-05 15:41:12 +0000 +++ lisp/emacs-lisp/cl-macs.el 2012-06-07 19:25:48 +0000 @@ -44,6 +44,7 @@ ;;; Code: (require 'cl-lib) +(require 'macroexp) (defmacro cl-pop2 (place) (declare (debug edebug-sexps)) @@ -54,58 +55,57 @@ (defvar cl-optimize-speed) -;; This kludge allows macros which use cl-transform-function-property +;; This kludge allows macros which use cl--transform-function-property ;; to be called at compile-time. (eval-and-compile - (or (fboundp 'cl-transform-function-property) - (defun cl-transform-function-property (n p f) + (or (fboundp 'cl--transform-function-property) + (defun cl--transform-function-property (n p f) `(put ',n ',p #'(lambda . ,f))))) ;;; Initialization. -(defvar cl-old-bc-file-form nil) - -;;; Some predicates for analyzing Lisp forms. These are used by various -;;; macro expanders to optimize the results in certain common cases. - -(defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max +;;; Some predicates for analyzing Lisp forms. +;; These are used by various +;; macro expanders to optimize the results in certain common cases. + +(defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max car-safe cdr-safe progn prog1 prog2)) -(defconst cl-safe-funcs '(* / % length memq list vector vectorp +(defconst cl--safe-funcs '(* / % length memq list vector vectorp < > <= >= = error)) -;;; Check if no side effects, and executes quickly. -(defun cl-simple-expr-p (x &optional size) +(defun cl--simple-expr-p (x &optional size) + "Check if no side effects, and executes quickly." (or size (setq size 10)) (if (and (consp x) (not (memq (car x) '(quote function cl-function)))) (and (symbolp (car x)) - (or (memq (car x) cl-simple-funcs) + (or (memq (car x) cl--simple-funcs) (get (car x) 'side-effect-free)) (progn (setq size (1- size)) (while (and (setq x (cdr x)) - (setq size (cl-simple-expr-p (car x) size)))) + (setq size (cl--simple-expr-p (car x) size)))) (and (null x) (>= size 0) size))) (and (> size 0) (1- size)))) -(defun cl-simple-exprs-p (xs) - (while (and xs (cl-simple-expr-p (car xs))) +(defun cl--simple-exprs-p (xs) + (while (and xs (cl--simple-expr-p (car xs))) (setq xs (cdr xs))) (not xs)) -;;; Check if no side effects. -(defun cl-safe-expr-p (x) +(defun cl--safe-expr-p (x) + "Check if no side effects." (or (not (and (consp x) (not (memq (car x) '(quote function cl-function))))) (and (symbolp (car x)) - (or (memq (car x) cl-simple-funcs) - (memq (car x) cl-safe-funcs) + (or (memq (car x) cl--simple-funcs) + (memq (car x) cl--safe-funcs) (get (car x) 'side-effect-free)) (progn - (while (and (setq x (cdr x)) (cl-safe-expr-p (car x)))) + (while (and (setq x (cdr x)) (cl--safe-expr-p (car x)))) (null x))))) ;;; Check if constant (i.e., no side effects or dependencies). -(defun cl-const-expr-p (x) +(defun cl--const-expr-p (x) (cond ((consp x) (or (eq (car x) 'quote) (and (memq (car x) '(function cl-function)) @@ -114,13 +114,8 @@ ((symbolp x) (and (memq x '(nil t)) t)) (t t))) -(defun cl-const-exprs-p (xs) - (while (and xs (cl-const-expr-p (car xs))) - (setq xs (cdr xs))) - (not xs)) - -(defun cl-const-expr-val (x) - (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x))) +(defun cl--const-expr-val (x) + (and (macroexp-const-p x) (if (consp x) (nth 1 x) x))) (defun cl-expr-access-order (x v) ;; This apparently tries to return nil iff the expression X evaluates @@ -129,15 +124,15 @@ ;; to). ;; FIXME: This is very naive, it doesn't even check to see if those ;; variables appear more than once. - (if (cl-const-expr-p x) v + (if (macroexp-const-p x) v (if (consp x) (progn (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v))) v) (if (eq x (car v)) (cdr v) '(t))))) -;;; Count number of times X refers to Y. Return nil for 0 times. -(defun cl-expr-contains (x y) +(defun cl--expr-contains (x y) + "Count number of times X refers to Y. Return nil for 0 times." ;; FIXME: This is naive, and it will cl-count Y as referred twice in ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on ;; non-macroexpanded code, so it may also miss some occurrences that would @@ -146,19 +141,19 @@ ((and (consp x) (not (memq (car x) '(quote function cl-function)))) (let ((sum 0)) (while (consp x) - (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))) - (setq sum (+ sum (or (cl-expr-contains x y) 0))) + (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0)))) + (setq sum (+ sum (or (cl--expr-contains x y) 0))) (and (> sum 0) sum))) (t nil))) -(defun cl-expr-contains-any (x y) - (while (and y (not (cl-expr-contains x (car y)))) (pop y)) +(defun cl--expr-contains-any (x y) + (while (and y (not (cl--expr-contains x (car y)))) (pop y)) y) -;;; Check whether X may depend on any of the symbols in Y. -(defun cl-expr-depends-p (x y) - (and (not (cl-const-expr-p x)) - (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y)))) +(defun cl--expr-depends-p (x y) + "Check whether X may depend on any of the symbols in Y." + (and (not (macroexp-const-p x)) + (or (not (cl--safe-expr-p x)) (cl--expr-contains-any x y)))) ;;; Symbols. @@ -224,7 +219,7 @@ def-body)) (doc-string 3) (indent 2)) - (let* ((res (cl-transform-lambda (cons args body) name)) + (let* ((res (cl--transform-lambda (cons args body) name)) (form `(defun ,name ,@(cdr res)))) (if (car res) `(progn ,(car res) ,form) form))) @@ -277,7 +272,7 @@ (&define name cl-macro-list cl-declarations-or-string def-body)) (doc-string 3) (indent 2)) - (let* ((res (cl-transform-lambda (cons args body) name)) + (let* ((res (cl--transform-lambda (cons args body) name)) (form `(defmacro ,name ,@(cdr res)))) (if (car res) `(progn ,(car res) ,form) form))) @@ -302,13 +297,13 @@ its argument list allows full Common Lisp conventions." (declare (debug (&or symbolp cl-lambda-expr))) (if (eq (car-safe func) 'lambda) - (let* ((res (cl-transform-lambda (cdr func) 'cl-none)) + (let* ((res (cl--transform-lambda (cdr func) 'cl-none)) (form `(function (lambda . ,(cdr res))))) (if (car res) `(progn ,(car res) ,form) form)) `(function ,func))) -(defun cl-transform-function-property (func prop form) - (let ((res (cl-transform-lambda form func))) +(defun cl--transform-function-property (func prop form) + (let ((res (cl--transform-lambda form func))) `(progn ,@(cdr (cdr (car res))) (put ',func ',prop #'(lambda . ,(cdr res)))))) @@ -356,7 +351,7 @@ )))) arglist))) -(defun cl-transform-lambda (form cl-bind-block) +(defun cl--transform-lambda (form cl-bind-block) (let* ((args (car form)) (body (cdr form)) (orig-args args) (cl-bind-defs nil) (cl-bind-enquote nil) (cl-bind-inits nil) (cl-bind-lets nil) (cl-bind-forms nil) @@ -385,8 +380,8 @@ (if (null args) (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) (if (memq '&optional simple-args) (push '&optional args)) - (cl-do-arglist args nil (- (length simple-args) - (if (memq '&optional simple-args) 1 0))) + (cl--do-arglist args nil (- (length simple-args) + (if (memq '&optional simple-args) 1 0))) (setq cl-bind-lets (nreverse cl-bind-lets)) (cl-list* (and cl-bind-inits `(cl-eval-when (compile load eval) ,@(nreverse cl-bind-inits))) @@ -408,7 +403,7 @@ ,@(nreverse cl-bind-forms) ,@body))))))) -(defun cl-do-arglist (args expr &optional num) ; uses bind-* +(defun cl--do-arglist (args expr &optional num) ; uses bind-* (if (nlistp args) (if (or (memq args cl-lambda-list-keywords) (not (symbolp args))) (error "Invalid argument name: %s" args) @@ -441,7 +436,7 @@ (while (and args (not (memq (car args) cl-lambda-list-keywords))) (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) restarg))) - (cl-do-arglist + (cl--do-arglist (pop args) (if (or laterarg (= safety 0)) poparg `(if ,minarg ,poparg @@ -454,18 +449,18 @@ (while (and args (not (memq (car args) cl-lambda-list-keywords))) (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) - (if (cddr arg) (cl-do-arglist (nth 2 arg) `(and ,restarg t))) + (if (cddr arg) (cl--do-arglist (nth 2 arg) `(and ,restarg t))) (let ((def (if (cdr arg) (nth 1 arg) (or (car cl-bind-defs) (nth 1 (assq (car arg) cl-bind-defs))))) (poparg `(pop ,restarg))) (and def cl-bind-enquote (setq def `',def)) - (cl-do-arglist (car arg) + (cl--do-arglist (car arg) (if def `(if ,restarg ,poparg ,def) poparg)) (setq num (1+ num)))))) (if (eq (car args) '&rest) (let ((arg (cl-pop2 args))) - (if (consp arg) (cl-do-arglist arg restarg))) + (if (consp arg) (cl--do-arglist arg restarg))) (or (eq (car args) '&key) (= safety 0) exactarg (push `(if ,restarg (signal 'wrong-number-of-arguments @@ -488,18 +483,18 @@ (if (cddr arg) (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--"))) (val `(car (cdr ,temp)))) - (cl-do-arglist temp look) - (cl-do-arglist varg + (cl--do-arglist temp look) + (cl--do-arglist varg `(if ,temp (prog1 ,val (setq ,temp t)) ,def))) - (cl-do-arglist + (cl--do-arglist varg `(car (cdr ,(if (null def) look `(or ,look - ,(if (eq (cl-const-expr-p def) t) - `'(nil ,(cl-const-expr-val def)) + ,(if (eq (cl--const-expr-p def) t) + `'(nil ,(cl--const-expr-val def)) `(list nil ,def)))))))) (push karg keys))))) (setq keys (nreverse keys)) @@ -523,13 +518,13 @@ (while (and args (not (memq (car args) cl-lambda-list-keywords))) (if (consp (car args)) (if (and cl-bind-enquote (cl-cadar args)) - (cl-do-arglist (caar args) + (cl--do-arglist (caar args) `',(cadr (pop args))) - (cl-do-arglist (caar args) (cadr (pop args)))) - (cl-do-arglist (pop args) nil)))) + (cl--do-arglist (caar args) (cadr (pop args)))) + (cl--do-arglist (pop args) nil)))) (if args (error "Malformed argument list %s" save-args))))) -(defun cl-arglist-args (args) +(defun cl--arglist-args (args) (if (nlistp args) (list args) (let ((res nil) (kind nil) arg) (while (consp args) @@ -538,7 +533,7 @@ (if (eq arg '&cl-defs) (pop args) (and (consp arg) kind (setq arg (car arg))) (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) - (setq res (nconc res (cl-arglist-args arg)))))) + (setq res (nconc res (cl--arglist-args arg)))))) (nconc res (and args (list args)))))) ;;;###autoload @@ -547,7 +542,7 @@ (debug (&define cl-macro-list def-form cl-declarations def-body))) (let* ((cl-bind-lets nil) (cl-bind-forms nil) (cl-bind-inits nil) (cl-bind-defs nil) (cl-bind-block 'cl-none) (cl-bind-enquote nil)) - (cl-do-arglist (or args '(&aux)) expr) + (cl--do-arglist (or args '(&aux)) expr) (append '(progn) cl-bind-inits (list `(let* ,(nreverse cl-bind-lets) ,@(nreverse cl-bind-forms) ,@body))))) @@ -571,18 +566,18 @@ (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) (cl-not-toplevel t)) (if (or (memq 'load when) (memq :load-toplevel when)) - (if comp (cons 'progn (mapcar 'cl-compile-time-too body)) + (if comp (cons 'progn (mapcar 'cl--compile-time-too body)) `(if nil nil ,@body)) (progn (if comp (eval (cons 'progn body))) nil))) (and (or (memq 'eval when) (memq :execute when)) (cons 'progn body)))) -(defun cl-compile-time-too (form) +(defun cl--compile-time-too (form) (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler)) (setq form (macroexpand form (cons '(cl-eval-when) byte-compile-macro-environment)))) (cond ((eq (car-safe form) 'progn) - (cons 'progn (mapcar 'cl-compile-time-too (cdr form)))) + (cons 'progn (mapcar 'cl--compile-time-too (cdr form)))) ((eq (car-safe form) 'cl-eval-when) (let ((when (nth 1 form))) (if (or (memq 'eval when) (memq :execute when)) @@ -624,7 +619,7 @@ Key values are compared by `eql'. \n(fn EXPR (KEYLIST BODY...)...)" (declare (indent 1) (debug (form &rest (sexp body)))) - (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) + (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (head-list nil) (body (cons 'cond @@ -667,7 +662,7 @@ \n(fn EXPR (TYPE BODY...)...)" (declare (indent 1) (debug (form &rest ([&or cl-type-spec "otherwise"] body)))) - (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) + (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (type-list nil) (body (cons 'cond @@ -680,7 +675,7 @@ ,temp ',(reverse type-list))) (t (push (car c) type-list) - (cl-make-type-test temp (car c)))) + (cl--make-type-test temp (car c)))) (or (cdr c) '(nil))))) clauses)))) (if (eq temp expr) body @@ -708,7 +703,7 @@ references may appear inside macro expansions, but not inside functions called from BODY." (declare (indent 1) (debug (symbolp body))) - (if (cl-safe-expr-p `(progn ,@body)) `(progn ,@body) + (if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body) `(cl-block-wrapper (catch ',(intern (format "--cl-block-%s--" name)) ,@body)))) @@ -734,16 +729,16 @@ ;;; The "cl-loop" macro. -(defvar cl-loop-args) (defvar cl-loop-accum-var) (defvar cl-loop-accum-vars) -(defvar cl-loop-bindings) (defvar cl-loop-body) (defvar cl-loop-destr-temps) -(defvar cl-loop-finally) (defvar cl-loop-finish-flag) -(defvar cl-loop-first-flag) -(defvar cl-loop-initially) (defvar cl-loop-map-form) (defvar cl-loop-name) -(defvar cl-loop-result) (defvar cl-loop-result-explicit) -(defvar cl-loop-result-var) (defvar cl-loop-steps) (defvar cl-loop-symbol-macs) +(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) +(defvar cl--loop-bindings) (defvar cl--loop-body) (defvar cl--loop-destr-temps) +(defvar cl--loop-finally) (defvar cl--loop-finish-flag) +(defvar cl--loop-first-flag) +(defvar cl--loop-initially) (defvar cl--loop-map-form) (defvar cl--loop-name) +(defvar cl--loop-result) (defvar cl--loop-result-explicit) +(defvar cl--loop-result-var) (defvar cl--loop-steps) (defvar cl--loop-symbol-macs) ;;;###autoload -(defmacro cl-loop (&rest cl-loop-args) +(defmacro cl-loop (&rest cl--loop-args) "The Common Lisp `cl-loop' macro. Valid clauses are: for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, @@ -759,30 +754,30 @@ \(fn CLAUSE...)" (declare (debug (&rest &or symbolp form))) - (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list cl-loop-args)))))) - `(cl-block nil (while t ,@cl-loop-args)) - (let ((cl-loop-name nil) (cl-loop-bindings nil) - (cl-loop-body nil) (cl-loop-steps nil) - (cl-loop-result nil) (cl-loop-result-explicit nil) - (cl-loop-result-var nil) (cl-loop-finish-flag nil) - (cl-loop-accum-var nil) (cl-loop-accum-vars nil) - (cl-loop-initially nil) (cl-loop-finally nil) - (cl-loop-map-form nil) (cl-loop-first-flag nil) - (cl-loop-destr-temps nil) (cl-loop-symbol-macs nil)) - (setq cl-loop-args (append cl-loop-args '(cl-end-loop))) - (while (not (eq (car cl-loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) - (if cl-loop-finish-flag - (push `((,cl-loop-finish-flag t)) cl-loop-bindings)) - (if cl-loop-first-flag - (progn (push `((,cl-loop-first-flag t)) cl-loop-bindings) - (push `(setq ,cl-loop-first-flag nil) cl-loop-steps))) - (let* ((epilogue (nconc (nreverse cl-loop-finally) - (list (or cl-loop-result-explicit cl-loop-result)))) - (ands (cl-loop-build-ands (nreverse cl-loop-body))) - (while-body (nconc (cadr ands) (nreverse cl-loop-steps))) + (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list cl--loop-args)))))) + `(cl-block nil (while t ,@cl--loop-args)) + (let ((cl--loop-name nil) (cl--loop-bindings nil) + (cl--loop-body nil) (cl--loop-steps nil) + (cl--loop-result nil) (cl--loop-result-explicit nil) + (cl--loop-result-var nil) (cl--loop-finish-flag nil) + (cl--loop-accum-var nil) (cl--loop-accum-vars nil) + (cl--loop-initially nil) (cl--loop-finally nil) + (cl--loop-map-form nil) (cl--loop-first-flag nil) + (cl--loop-destr-temps nil) (cl--loop-symbol-macs nil)) + (setq cl--loop-args (append cl--loop-args '(cl-end-loop))) + (while (not (eq (car cl--loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) + (if cl--loop-finish-flag + (push `((,cl--loop-finish-flag t)) cl--loop-bindings)) + (if cl--loop-first-flag + (progn (push `((,cl--loop-first-flag t)) cl--loop-bindings) + (push `(setq ,cl--loop-first-flag nil) cl--loop-steps))) + (let* ((epilogue (nconc (nreverse cl--loop-finally) + (list (or cl--loop-result-explicit cl--loop-result)))) + (ands (cl--loop-build-ands (nreverse cl--loop-body))) + (while-body (nconc (cadr ands) (nreverse cl--loop-steps))) (body (append - (nreverse cl-loop-initially) - (list (if cl-loop-map-form + (nreverse cl--loop-initially) + (list (if cl--loop-map-form `(cl-block --cl-finish-- ,(cl-subst (if (eq (car ands) t) while-body @@ -790,25 +785,25 @@ (cl-return-from --cl-finish-- nil)) while-body)) - '--cl-map cl-loop-map-form)) + '--cl-map cl--loop-map-form)) `(while ,(car ands) ,@while-body))) - (if cl-loop-finish-flag - (if (equal epilogue '(nil)) (list cl-loop-result-var) - `((if ,cl-loop-finish-flag - (progn ,@epilogue) ,cl-loop-result-var))) + (if cl--loop-finish-flag + (if (equal epilogue '(nil)) (list cl--loop-result-var) + `((if ,cl--loop-finish-flag + (progn ,@epilogue) ,cl--loop-result-var))) epilogue)))) - (if cl-loop-result-var (push (list cl-loop-result-var) cl-loop-bindings)) - (while cl-loop-bindings - (if (cdar cl-loop-bindings) - (setq body (list (cl-loop-let (pop cl-loop-bindings) body t))) + (if cl--loop-result-var (push (list cl--loop-result-var) cl--loop-bindings)) + (while cl--loop-bindings + (if (cdar cl--loop-bindings) + (setq body (list (cl--loop-let (pop cl--loop-bindings) body t))) (let ((lets nil)) - (while (and cl-loop-bindings - (not (cdar cl-loop-bindings))) - (push (car (pop cl-loop-bindings)) lets)) - (setq body (list (cl-loop-let lets body nil)))))) - (if cl-loop-symbol-macs - (setq body (list `(cl-symbol-macrolet ,cl-loop-symbol-macs ,@body)))) - `(cl-block ,cl-loop-name ,@body))))) + (while (and cl--loop-bindings + (not (cdar cl--loop-bindings))) + (push (car (pop cl--loop-bindings)) lets)) + (setq body (list (cl--loop-let lets body nil)))))) + (if cl--loop-symbol-macs + (setq body (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body)))) + `(cl-block ,cl--loop-name ,@body))))) ;; Below is a complete spec for cl-loop, in several parts that correspond ;; to the syntax given in CLtL2. The specs do more than specify where @@ -963,33 +958,33 @@ (defun cl-parse-loop-clause () ; uses loop-* - (let ((word (pop cl-loop-args)) + (let ((word (pop cl--loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) (key-types '(key-code key-codes key-seq key-seqs key-binding key-bindings))) (cond - ((null cl-loop-args) + ((null cl--loop-args) (error "Malformed `cl-loop' macro")) ((eq word 'named) - (setq cl-loop-name (pop cl-loop-args))) + (setq cl--loop-name (pop cl--loop-args))) ((eq word 'initially) - (if (memq (car cl-loop-args) '(do doing)) (pop cl-loop-args)) - (or (consp (car cl-loop-args)) (error "Syntax error on `initially' clause")) - (while (consp (car cl-loop-args)) - (push (pop cl-loop-args) cl-loop-initially))) + (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) + (or (consp (car cl--loop-args)) (error "Syntax error on `initially' clause")) + (while (consp (car cl--loop-args)) + (push (pop cl--loop-args) cl--loop-initially))) ((eq word 'finally) - (if (eq (car cl-loop-args) 'return) - (setq cl-loop-result-explicit (or (cl-pop2 cl-loop-args) '(quote nil))) - (if (memq (car cl-loop-args) '(do doing)) (pop cl-loop-args)) - (or (consp (car cl-loop-args)) (error "Syntax error on `finally' clause")) - (if (and (eq (caar cl-loop-args) 'return) (null cl-loop-name)) - (setq cl-loop-result-explicit (or (nth 1 (pop cl-loop-args)) '(quote nil))) - (while (consp (car cl-loop-args)) - (push (pop cl-loop-args) cl-loop-finally))))) + (if (eq (car cl--loop-args) 'return) + (setq cl--loop-result-explicit (or (cl-pop2 cl--loop-args) '(quote nil))) + (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) + (or (consp (car cl--loop-args)) (error "Syntax error on `finally' clause")) + (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name)) + (setq cl--loop-result-explicit (or (nth 1 (pop cl--loop-args)) '(quote nil))) + (while (consp (car cl--loop-args)) + (push (pop cl--loop-args) cl--loop-finally))))) ((memq word '(for as)) (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) @@ -997,33 +992,33 @@ (while ;; Use `cl-gensym' rather than `make-symbol'. It's important that ;; (not (eq (symbol-name var1) (symbol-name var2))) because - ;; these vars get added to the cl-macro-environment. - (let ((var (or (pop cl-loop-args) (cl-gensym "--cl-var--")))) - (setq word (pop cl-loop-args)) - (if (eq word 'being) (setq word (pop cl-loop-args))) - (if (memq word '(the each)) (setq word (pop cl-loop-args))) + ;; these vars get added to the macro-environment. + (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--")))) + (setq word (pop cl--loop-args)) + (if (eq word 'being) (setq word (pop cl--loop-args))) + (if (memq word '(the each)) (setq word (pop cl--loop-args))) (if (memq word '(buffer buffers)) - (setq word 'in cl-loop-args (cons '(buffer-list) cl-loop-args))) + (setq word 'in cl--loop-args (cons '(buffer-list) cl--loop-args))) (cond ((memq word '(from downfrom upfrom to downto upto above below by)) - (push word cl-loop-args) - (if (memq (car cl-loop-args) '(downto above)) + (push word cl--loop-args) + (if (memq (car cl--loop-args) '(downto above)) (error "Must specify `from' value for downward cl-loop")) - (let* ((down (or (eq (car cl-loop-args) 'downfrom) - (memq (cl-caddr cl-loop-args) '(downto above)))) - (excl (or (memq (car cl-loop-args) '(above below)) - (memq (cl-caddr cl-loop-args) '(above below)))) - (start (and (memq (car cl-loop-args) '(from upfrom downfrom)) - (cl-pop2 cl-loop-args))) - (end (and (memq (car cl-loop-args) + (let* ((down (or (eq (car cl--loop-args) 'downfrom) + (memq (cl-caddr cl--loop-args) '(downto above)))) + (excl (or (memq (car cl--loop-args) '(above below)) + (memq (cl-caddr cl--loop-args) '(above below)))) + (start (and (memq (car cl--loop-args) '(from upfrom downfrom)) + (cl-pop2 cl--loop-args))) + (end (and (memq (car cl--loop-args) '(to upto downto above below)) - (cl-pop2 cl-loop-args))) - (step (and (eq (car cl-loop-args) 'by) (cl-pop2 cl-loop-args))) - (end-var (and (not (cl-const-expr-p end)) + (cl-pop2 cl--loop-args))) + (step (and (eq (car cl--loop-args) 'by) (cl-pop2 cl--loop-args))) + (end-var (and (not (macroexp-const-p end)) (make-symbol "--cl-var--"))) - (step-var (and (not (cl-const-expr-p step)) + (step-var (and (not (macroexp-const-p step)) (make-symbol "--cl-var--")))) (and step (numberp step) (<= step 0) (error "Loop `by' value is not positive: %s" step)) @@ -1034,7 +1029,7 @@ (if end (push (list (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) cl-loop-body)) + var (or end-var end)) cl--loop-body)) (push (list var (list (if down '- '+) var (or step-var step 1))) loop-for-steps))) @@ -1043,18 +1038,18 @@ (let* ((on (eq word 'on)) (temp (if (and on (symbolp var)) var (make-symbol "--cl-var--")))) - (push (list temp (pop cl-loop-args)) loop-for-bindings) - (push `(consp ,temp) cl-loop-body) + (push (list temp (pop cl--loop-args)) loop-for-bindings) + (push `(consp ,temp) cl--loop-body) (if (eq word 'in-ref) - (push (list var `(car ,temp)) cl-loop-symbol-macs) + (push (list var `(car ,temp)) cl--loop-symbol-macs) (or (eq temp var) (progn (push (list var nil) loop-for-bindings) (push (list var (if on temp `(car ,temp))) loop-for-sets)))) (push (list temp - (if (eq (car cl-loop-args) 'by) - (let ((step (cl-pop2 cl-loop-args))) + (if (eq (car cl--loop-args) 'by) + (let ((step (cl-pop2 cl--loop-args))) (if (and (memq (car-safe step) '(quote function cl-function)) @@ -1065,22 +1060,22 @@ loop-for-steps))) ((eq word '=) - (let* ((start (pop cl-loop-args)) - (then (if (eq (car cl-loop-args) 'then) (cl-pop2 cl-loop-args) start))) + (let* ((start (pop cl--loop-args)) + (then (if (eq (car cl--loop-args) 'then) (cl-pop2 cl--loop-args) start))) (push (list var nil) loop-for-bindings) - (if (or ands (eq (car cl-loop-args) 'and)) + (if (or ands (eq (car cl--loop-args) 'and)) (progn (push `(,var - (if ,(or cl-loop-first-flag - (setq cl-loop-first-flag + (if ,(or cl--loop-first-flag + (setq cl--loop-first-flag (make-symbol "--cl-var--"))) ,start ,var)) loop-for-sets) (push (list var then) loop-for-steps)) (push (list var (if (eq start then) start - `(if ,(or cl-loop-first-flag - (setq cl-loop-first-flag + `(if ,(or cl--loop-first-flag + (setq cl--loop-first-flag (make-symbol "--cl-var--"))) ,start ,then))) loop-for-sets)))) @@ -1088,27 +1083,27 @@ ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) (temp-idx (make-symbol "--cl-idx--"))) - (push (list temp-vec (pop cl-loop-args)) loop-for-bindings) + (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) (push `(< (setq ,temp-idx (1+ ,temp-idx)) - (length ,temp-vec)) cl-loop-body) + (length ,temp-vec)) cl--loop-body) (if (eq word 'across-ref) (push (list var `(aref ,temp-vec ,temp-idx)) - cl-loop-symbol-macs) + cl--loop-symbol-macs) (push (list var nil) loop-for-bindings) (push (list var `(aref ,temp-vec ,temp-idx)) loop-for-sets)))) ((memq word '(element elements)) - (let ((ref (or (memq (car cl-loop-args) '(in-ref of-ref)) - (and (not (memq (car cl-loop-args) '(in of))) + (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref)) + (and (not (memq (car cl--loop-args) '(in of))) (error "Expected `of'")))) - (seq (cl-pop2 cl-loop-args)) + (seq (cl-pop2 cl--loop-args)) (temp-seq (make-symbol "--cl-seq--")) - (temp-idx (if (eq (car cl-loop-args) 'using) - (if (and (= (length (cadr cl-loop-args)) 2) - (eq (cl-caadr cl-loop-args) 'index)) - (cadr (cl-pop2 cl-loop-args)) + (temp-idx (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (eq (cl-caadr cl--loop-args) 'index)) + (cadr (cl-pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-idx--")))) (push (list temp-seq seq) loop-for-bindings) @@ -1118,13 +1113,13 @@ (push (list temp-len `(length ,temp-seq)) loop-for-bindings) (push (list var `(elt ,temp-seq temp-idx)) - cl-loop-symbol-macs) - (push `(< ,temp-idx ,temp-len) cl-loop-body)) + cl--loop-symbol-macs) + (push `(< ,temp-idx ,temp-len) cl--loop-body)) (push (list var nil) loop-for-bindings) (push `(and ,temp-seq (or (consp ,temp-seq) (< ,temp-idx (length ,temp-seq)))) - cl-loop-body) + cl--loop-body) (push (list var `(if (consp ,temp-seq) (pop ,temp-seq) (aref ,temp-seq ,temp-idx))) @@ -1133,33 +1128,33 @@ loop-for-steps))) ((memq word hash-types) - (or (memq (car cl-loop-args) '(in of)) (error "Expected `of'")) - (let* ((table (cl-pop2 cl-loop-args)) - (other (if (eq (car cl-loop-args) 'using) - (if (and (= (length (cadr cl-loop-args)) 2) - (memq (cl-caadr cl-loop-args) hash-types) - (not (eq (cl-caadr cl-loop-args) word))) - (cadr (cl-pop2 cl-loop-args)) + (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) + (let* ((table (cl-pop2 cl--loop-args)) + (other (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (cl-caadr cl--loop-args) hash-types) + (not (eq (cl-caadr cl--loop-args) word))) + (cadr (cl-pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(hash-value hash-values)) (setq var (prog1 other (setq other var)))) - (setq cl-loop-map-form + (setq cl--loop-map-form `(maphash (lambda (,var ,other) . --cl-map) ,table)))) ((memq word '(symbol present-symbol external-symbol symbols present-symbols external-symbols)) - (let ((ob (and (memq (car cl-loop-args) '(in of)) (cl-pop2 cl-loop-args)))) - (setq cl-loop-map-form + (let ((ob (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args)))) + (setq cl--loop-map-form `(mapatoms (lambda (,var) . --cl-map) ,ob)))) ((memq word '(overlay overlays extent extents)) (let ((buf nil) (from nil) (to nil)) - (while (memq (car cl-loop-args) '(in of from to)) - (cond ((eq (car cl-loop-args) 'from) (setq from (cl-pop2 cl-loop-args))) - ((eq (car cl-loop-args) 'to) (setq to (cl-pop2 cl-loop-args))) - (t (setq buf (cl-pop2 cl-loop-args))))) - (setq cl-loop-map-form + (while (memq (car cl--loop-args) '(in of from to)) + (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) + (t (setq buf (cl-pop2 cl--loop-args))))) + (setq cl--loop-map-form `(cl-map-extents (lambda (,var ,(make-symbol "--cl-var--")) (progn . --cl-map) nil) @@ -1169,33 +1164,33 @@ (let ((buf nil) (prop nil) (from nil) (to nil) (var1 (make-symbol "--cl-var1--")) (var2 (make-symbol "--cl-var2--"))) - (while (memq (car cl-loop-args) '(in of property from to)) - (cond ((eq (car cl-loop-args) 'from) (setq from (cl-pop2 cl-loop-args))) - ((eq (car cl-loop-args) 'to) (setq to (cl-pop2 cl-loop-args))) - ((eq (car cl-loop-args) 'property) - (setq prop (cl-pop2 cl-loop-args))) - (t (setq buf (cl-pop2 cl-loop-args))))) + (while (memq (car cl--loop-args) '(in of property from to)) + (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'property) + (setq prop (cl-pop2 cl--loop-args))) + (t (setq buf (cl-pop2 cl--loop-args))))) (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) (setq var1 (car var) var2 (cdr var)) (push (list var `(cons ,var1 ,var2)) loop-for-sets)) - (setq cl-loop-map-form + (setq cl--loop-map-form `(cl-map-intervals (lambda (,var1 ,var2) . --cl-map) ,buf ,prop ,from ,to)))) ((memq word key-types) - (or (memq (car cl-loop-args) '(in of)) (error "Expected `of'")) - (let ((cl-map (cl-pop2 cl-loop-args)) - (other (if (eq (car cl-loop-args) 'using) - (if (and (= (length (cadr cl-loop-args)) 2) - (memq (cl-caadr cl-loop-args) key-types) - (not (eq (cl-caadr cl-loop-args) word))) - (cadr (cl-pop2 cl-loop-args)) + (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) + (let ((cl-map (cl-pop2 cl--loop-args)) + (other (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (cl-caadr cl--loop-args) key-types) + (not (eq (cl-caadr cl--loop-args) word))) + (cadr (cl-pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(key-binding key-bindings)) (setq var (prog1 other (setq other var)))) - (setq cl-loop-map-form + (setq cl--loop-map-form `(,(if (memq word '(key-seq key-seqs)) 'cl-map-keymap-recursively 'map-keymap) (lambda (,var ,other) . --cl-map) ,cl-map)))) @@ -1207,12 +1202,12 @@ (push (list temp nil) loop-for-bindings) (push `(prog1 (not (eq ,var ,temp)) (or ,temp (setq ,temp ,var))) - cl-loop-body) + cl--loop-body) (push (list var `(next-frame ,var)) loop-for-steps))) ((memq word '(window windows)) - (let ((scr (and (memq (car cl-loop-args) '(in of)) (cl-pop2 cl-loop-args))) + (let ((scr (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args))) (temp (make-symbol "--cl-var--")) (minip (make-symbol "--cl-minip--"))) (push (list var (if scr @@ -1229,52 +1224,52 @@ (push (list temp nil) loop-for-bindings) (push `(prog1 (not (eq ,var ,temp)) (or ,temp (setq ,temp ,var))) - cl-loop-body) + cl--loop-body) (push (list var `(next-window ,var ,minip)) loop-for-steps))) (t (let ((handler (and (symbolp word) - (get word 'cl-loop-for-handler)))) + (get word 'cl--loop-for-handler)))) (if handler (funcall handler var) (error "Expected a `for' preposition, found %s" word))))) - (eq (car cl-loop-args) 'and)) + (eq (car cl--loop-args) 'and)) (setq ands t) - (pop cl-loop-args)) + (pop cl--loop-args)) (if (and ands loop-for-bindings) - (push (nreverse loop-for-bindings) cl-loop-bindings) - (setq cl-loop-bindings (nconc (mapcar 'list loop-for-bindings) - cl-loop-bindings))) + (push (nreverse loop-for-bindings) cl--loop-bindings) + (setq cl--loop-bindings (nconc (mapcar 'list loop-for-bindings) + cl--loop-bindings))) (if loop-for-sets (push `(progn - ,(cl-loop-let (nreverse loop-for-sets) 'setq ands) - t) cl-loop-body)) + ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) + t) cl--loop-body)) (if loop-for-steps (push (cons (if ands 'cl-psetq 'setq) (apply 'append (nreverse loop-for-steps))) - cl-loop-steps)))) + cl--loop-steps)))) ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) - (push (list (list temp (pop cl-loop-args))) cl-loop-bindings) - (push `(>= (setq ,temp (1- ,temp)) 0) cl-loop-body))) + (push (list (list temp (pop cl--loop-args))) cl--loop-bindings) + (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body))) ((memq word '(collect collecting)) - (let ((what (pop cl-loop-args)) - (var (cl-loop-handle-accum nil 'nreverse))) - (if (eq var cl-loop-accum-var) - (push `(progn (push ,what ,var) t) cl-loop-body) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum nil 'nreverse))) + (if (eq var cl--loop-accum-var) + (push `(progn (push ,what ,var) t) cl--loop-body) (push `(progn (setq ,var (nconc ,var (list ,what))) - t) cl-loop-body)))) + t) cl--loop-body)))) ((memq word '(nconc nconcing append appending)) - (let ((what (pop cl-loop-args)) - (var (cl-loop-handle-accum nil 'nreverse))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum nil 'nreverse))) (push `(progn (setq ,var - ,(if (eq var cl-loop-accum-var) + ,(if (eq var cl--loop-accum-var) `(nconc (,(if (memq word '(nconc nconcing)) #'nreverse #'reverse) @@ -1282,113 +1277,113 @@ ,var) `(,(if (memq word '(nconc nconcing)) #'nconc #'append) - ,var ,what))) t) cl-loop-body))) + ,var ,what))) t) cl--loop-body))) ((memq word '(concat concating)) - (let ((what (pop cl-loop-args)) - (var (cl-loop-handle-accum ""))) - (push `(progn (cl-callf concat ,var ,what) t) cl-loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum ""))) + (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body))) ((memq word '(vconcat vconcating)) - (let ((what (pop cl-loop-args)) - (var (cl-loop-handle-accum []))) - (push `(progn (cl-callf vconcat ,var ,what) t) cl-loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum []))) + (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body))) ((memq word '(sum summing)) - (let ((what (pop cl-loop-args)) - (var (cl-loop-handle-accum 0))) - (push `(progn (cl-incf ,var ,what) t) cl-loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum 0))) + (push `(progn (cl-incf ,var ,what) t) cl--loop-body))) ((memq word '(count counting)) - (let ((what (pop cl-loop-args)) - (var (cl-loop-handle-accum 0))) - (push `(progn (if ,what (cl-incf ,var)) t) cl-loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum 0))) + (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) ((memq word '(minimize minimizing maximize maximizing)) - (let* ((what (pop cl-loop-args)) - (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--"))) - (var (cl-loop-handle-accum nil)) + (let* ((what (pop cl--loop-args)) + (temp (if (cl--simple-expr-p what) what (make-symbol "--cl-var--"))) + (var (cl--loop-handle-accum nil)) (func (intern (substring (symbol-name word) 0 3))) (set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) (push `(progn ,(if (eq temp what) set `(let ((,temp ,what)) ,set)) - t) cl-loop-body))) + t) cl--loop-body))) ((eq word 'with) (let ((bindings nil)) - (while (progn (push (list (pop cl-loop-args) - (and (eq (car cl-loop-args) '=) (cl-pop2 cl-loop-args))) + (while (progn (push (list (pop cl--loop-args) + (and (eq (car cl--loop-args) '=) (cl-pop2 cl--loop-args))) bindings) - (eq (car cl-loop-args) 'and)) - (pop cl-loop-args)) - (push (nreverse bindings) cl-loop-bindings))) + (eq (car cl--loop-args) 'and)) + (pop cl--loop-args)) + (push (nreverse bindings) cl--loop-bindings))) ((eq word 'while) - (push (pop cl-loop-args) cl-loop-body)) + (push (pop cl--loop-args) cl--loop-body)) ((eq word 'until) - (push `(not ,(pop cl-loop-args)) cl-loop-body)) + (push `(not ,(pop cl--loop-args)) cl--loop-body)) ((eq word 'always) - (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-flag--"))) - (push `(setq ,cl-loop-finish-flag ,(pop cl-loop-args)) cl-loop-body) - (setq cl-loop-result t)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body) + (setq cl--loop-result t)) ((eq word 'never) - (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-flag--"))) - (push `(setq ,cl-loop-finish-flag (not ,(pop cl-loop-args))) - cl-loop-body) - (setq cl-loop-result t)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args))) + cl--loop-body) + (setq cl--loop-result t)) ((eq word 'thereis) - (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-flag--"))) - (or cl-loop-result-var (setq cl-loop-result-var (make-symbol "--cl-var--"))) - (push `(setq ,cl-loop-finish-flag - (not (setq ,cl-loop-result-var ,(pop cl-loop-args)))) - cl-loop-body)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl--loop-finish-flag + (not (setq ,cl--loop-result-var ,(pop cl--loop-args)))) + cl--loop-body)) ((memq word '(if when unless)) - (let* ((cond (pop cl-loop-args)) - (then (let ((cl-loop-body nil)) + (let* ((cond (pop cl--loop-args)) + (then (let ((cl--loop-body nil)) (cl-parse-loop-clause) - (cl-loop-build-ands (nreverse cl-loop-body)))) - (else (let ((cl-loop-body nil)) - (if (eq (car cl-loop-args) 'else) - (progn (pop cl-loop-args) (cl-parse-loop-clause))) - (cl-loop-build-ands (nreverse cl-loop-body)))) + (cl--loop-build-ands (nreverse cl--loop-body)))) + (else (let ((cl--loop-body nil)) + (if (eq (car cl--loop-args) 'else) + (progn (pop cl--loop-args) (cl-parse-loop-clause))) + (cl--loop-build-ands (nreverse cl--loop-body)))) (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car cl-loop-args) 'end) (pop cl-loop-args)) + (if (eq (car cl--loop-args) 'end) (pop cl--loop-args)) (if (eq word 'unless) (setq then (prog1 else (setq else then)))) (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) (if simple (nth 1 else) (list (nth 2 else)))))) - (if (cl-expr-contains form 'it) + (if (cl--expr-contains form 'it) (let ((temp (make-symbol "--cl-var--"))) - (push (list temp) cl-loop-bindings) + (push (list temp) cl--loop-bindings) (setq form `(if (setq ,temp ,cond) ,@(cl-subst temp 'it form)))) (setq form `(if ,cond ,@form))) - (push (if simple `(progn ,form t) form) cl-loop-body)))) + (push (if simple `(progn ,form t) form) cl--loop-body)))) ((memq word '(do doing)) (let ((body nil)) - (or (consp (car cl-loop-args)) (error "Syntax error on `do' clause")) - (while (consp (car cl-loop-args)) (push (pop cl-loop-args) body)) - (push (cons 'progn (nreverse (cons t body))) cl-loop-body))) + (or (consp (car cl--loop-args)) (error "Syntax error on `do' clause")) + (while (consp (car cl--loop-args)) (push (pop cl--loop-args) body)) + (push (cons 'progn (nreverse (cons t body))) cl--loop-body))) ((eq word 'return) - (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-var--"))) - (or cl-loop-result-var (setq cl-loop-result-var (make-symbol "--cl-var--"))) - (push `(setq ,cl-loop-result-var ,(pop cl-loop-args) - ,cl-loop-finish-flag nil) cl-loop-body)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-var--"))) + (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl--loop-result-var ,(pop cl--loop-args) + ,cl--loop-finish-flag nil) cl--loop-body)) (t - (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) + (let ((handler (and (symbolp word) (get word 'cl--loop-handler)))) (or handler (error "Expected a cl-loop keyword, found %s" word)) (funcall handler)))) - (if (eq (car cl-loop-args) 'and) - (progn (pop cl-loop-args) (cl-parse-loop-clause))))) + (if (eq (car cl--loop-args) 'and) + (progn (pop cl--loop-args) (cl-parse-loop-clause))))) -(defun cl-loop-let (specs body par) ; uses loop-* +(defun cl--loop-let (specs body par) ; uses loop-* (let ((p specs) (temps nil) (new nil)) (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p)))) (setq p (cdr p))) @@ -1396,7 +1391,7 @@ (progn (setq par nil p specs) (while p - (or (cl-const-expr-p (cl-cadar p)) + (or (macroexp-const-p (cl-cadar p)) (let ((temp (make-symbol "--cl-var--"))) (push (list temp (cl-cadar p)) temps) (setcar (cdar p) temp))) @@ -1405,10 +1400,10 @@ (if (and (consp (car specs)) (listp (caar specs))) (let* ((spec (caar specs)) (nspecs nil) (expr (cadr (pop specs))) - (temp (cdr (or (assq spec cl-loop-destr-temps) + (temp (cdr (or (assq spec cl--loop-destr-temps) (car (push (cons spec (or (last spec 0) (make-symbol "--cl-var--"))) - cl-loop-destr-temps)))))) + cl--loop-destr-temps)))))) (push (list temp expr) new) (while (consp spec) (push (list (pop spec) @@ -1422,22 +1417,22 @@ `(,(if par 'let 'let*) ,(nconc (nreverse temps) (nreverse new)) ,@body)))) -(defun cl-loop-handle-accum (def &optional func) ; uses loop-* - (if (eq (car cl-loop-args) 'into) - (let ((var (cl-pop2 cl-loop-args))) - (or (memq var cl-loop-accum-vars) - (progn (push (list (list var def)) cl-loop-bindings) - (push var cl-loop-accum-vars))) +(defun cl--loop-handle-accum (def &optional func) ; uses loop-* + (if (eq (car cl--loop-args) 'into) + (let ((var (cl-pop2 cl--loop-args))) + (or (memq var cl--loop-accum-vars) + (progn (push (list (list var def)) cl--loop-bindings) + (push var cl--loop-accum-vars))) var) - (or cl-loop-accum-var + (or cl--loop-accum-var (progn - (push (list (list (setq cl-loop-accum-var (make-symbol "--cl-var--")) def)) - cl-loop-bindings) - (setq cl-loop-result (if func (list func cl-loop-accum-var) - cl-loop-accum-var)) - cl-loop-accum-var)))) + (push (list (list (setq cl--loop-accum-var (make-symbol "--cl-var--")) def)) + cl--loop-bindings) + (setq cl--loop-result (if func (list func cl--loop-accum-var) + cl--loop-accum-var)) + cl--loop-accum-var)))) -(defun cl-loop-build-ands (clauses) +(defun cl--loop-build-ands (clauses) (let ((ands nil) (body nil)) (while clauses @@ -1671,9 +1666,10 @@ (push var vars) (push `(cl-function (lambda . ,(cdar bindings))) sets) (push var sets) - (push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args) - `(cl-list* 'funcall ',var - cl-labels-args)) + (push (cons (car (pop bindings)) + `(lambda (&rest cl-labels-args) + (cl-list* 'funcall ',var + cl-labels-args))) cl-macro-environment))) (cl-macroexpand-all `(cl-lexical-let ,vars (setq ,@sets) ,@body) cl-macro-environment))) @@ -1695,10 +1691,10 @@ `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) (if (null bindings) (cons 'progn body) (let* ((name (caar bindings)) - (res (cl-transform-lambda (cdar bindings) name))) + (res (cl--transform-lambda (cdar bindings) name))) (eval (car res)) (cl-macroexpand-all (cons 'progn body) - (cons (cl-list* name 'lambda (cdr res)) + (cons (cons name `(lambda ,@(cdr res))) cl-macro-environment)))))) ;;;###autoload @@ -1737,13 +1733,12 @@ bindings)) (ebody (cl-macroexpand-all - (cons 'progn body) - (nconc (mapcar (function (lambda (x) - (list (symbol-name (car x)) - `(symbol-value ,(cl-caddr x)) - t))) vars) - (list '(defun . cl-defun-expander)) - cl-macro-environment)))) + `(cl-symbol-macrolet + ,(mapcar (lambda (x) + `(,(car x) (symbol-value ,(cl-caddr x)))) + vars) + ,@body) + cl-macro-environment))) (if (not (get (car (last cl-closure-vars)) 'used)) ;; Turn (let ((foo (cl-gensym))) ;; (set foo ) ...(symbol-value foo)...) @@ -1784,12 +1779,6 @@ (setq body (list `(cl-lexical-let (,(pop bindings)) ,@body)))) (car body))) -(defun cl-defun-expander (func &rest rest) - `(progn - (defalias ',func #'(lambda ,@rest)) - ',func)) - - ;;; Multiple values. ;;;###autoload @@ -1912,7 +1901,7 @@ ;;; Generalized variables. ;;;###autoload -(defmacro cl-define-setf-method (func args &rest body) +(defmacro cl-define-setf-expander (func args &rest body) "Define a `cl-setf' method. This method shows how to handle `cl-setf's to places of the form (NAME ARGS...). The argument forms ARGS are bound according to ARGLIST, as if NAME were @@ -1927,14 +1916,13 @@ `(cl-eval-when (compile load eval) ,@(if (stringp (car body)) (list `(put ',func 'setf-documentation ,(pop body)))) - ,(cl-transform-function-property + ,(cl--transform-function-property func 'setf-method (cons args body)))) -(defalias 'cl-define-setf-expander 'cl-define-setf-method) ;;;###autoload (defmacro cl-defsetf (func arg1 &rest args) "Define a `cl-setf' method. -This macro is an easy-to-use substitute for `cl-define-setf-method' that works +This macro is an easy-to-use substitute for `cl-define-setf-expander' that works well for simple place forms. In the simple `cl-defsetf' form, `cl-setf's of the form (cl-setf (NAME ARGS...) VAL) are transformed to function or macro calls of the form (FUNC ARGS... VAL). Example: @@ -1990,7 +1978,7 @@ lets2 (cons (list (car p1) (car p2)) lets2) p1 (cdr p1) p2 (cdr p2)))) (if restarg (setq lets2 (cons (list restarg rest-temps) lets2))) - `(cl-define-setf-method ,func ,arg1 + `(cl-define-setf-expander ,func ,arg1 ,@(and docstr (list docstr)) (let* ,(nreverse @@ -2143,7 +2131,7 @@ ;; (setq a 7) or (setq a nil) depending on whether B is nil or not. ;; This is useful when you have control over the PLACE but not over ;; the VALUE, as is the case in define-minor-mode's :variable. -(cl-define-setf-method eq (place val) +(cl-define-setf-expander eq (place val) (let ((method (cl-get-setf-method place cl-macro-environment)) (val-temp (make-symbol "--eq-val--")) (store-temp (make-symbol "--eq-store--"))) @@ -2160,7 +2148,7 @@ ;; available while compiling cl-macs, we fake it by referring to the global ;; variable cl-macro-environment directly. -(cl-define-setf-method apply (func arg1 &rest rest) +(cl-define-setf-expander apply (func arg1 &rest rest) (or (and (memq (car-safe func) '(quote function cl-function)) (symbolp (car-safe (cdr-safe func)))) (error "First arg to apply in cl-setf is not (function SYM): %s" func)) @@ -2177,7 +2165,7 @@ (error "%s is not suitable for use with setf-of-apply" func)) `(apply ',(car form) ,@(cdr form)))) -(cl-define-setf-method nthcdr (n place) +(cl-define-setf-expander nthcdr (n place) (let ((method (cl-get-setf-method place cl-macro-environment)) (n-temp (make-symbol "--cl-nthcdr-n--")) (store-temp (make-symbol "--cl-nthcdr-store--"))) @@ -2190,7 +2178,7 @@ ,(nth 3 method) ,store-temp) `(nthcdr ,n-temp ,(nth 4 method))))) -(cl-define-setf-method cl-getf (place tag &optional def) +(cl-define-setf-expander cl-getf (place tag &optional def) (let ((method (cl-get-setf-method place cl-macro-environment)) (tag-temp (make-symbol "--cl-getf-tag--")) (def-temp (make-symbol "--cl-getf-def--")) @@ -2203,7 +2191,7 @@ ,(nth 3 method) ,store-temp) `(cl-getf ,(nth 4 method) ,tag-temp ,def-temp)))) -(cl-define-setf-method substring (place from &optional to) +(cl-define-setf-expander substring (place from &optional to) (let ((method (cl-get-setf-method place cl-macro-environment)) (from-temp (make-symbol "--cl-substring-from--")) (to-temp (make-symbol "--cl-substring-to--")) @@ -2257,12 +2245,12 @@ (lets nil) (subs nil) (optimize (and (not (eq opt-expr 'no-opt)) (or (and (not (eq opt-expr 'unsafe)) - (cl-safe-expr-p opt-expr)) + (cl--safe-expr-p opt-expr)) (cl-setf-simple-store-p (car (nth 2 method)) (nth 3 method))))) - (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place))))) + (simple (and optimize (consp place) (cl--simple-exprs-p (cdr place))))) (while values - (if (or simple (cl-const-expr-p (car values))) + (if (or simple (macroexp-const-p (car values))) (push (cons (pop temps) (pop values)) subs) (push (list (pop temps) (pop values)) lets))) (list (nreverse lets) @@ -2272,14 +2260,14 @@ (defun cl-setf-do-store (spec val) (let ((sym (car spec)) (form (cdr spec))) - (if (or (cl-const-expr-p val) - (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1)) + (if (or (macroexp-const-p val) + (and (cl--simple-expr-p val) (eq (cl--expr-contains form sym) 1)) (cl-setf-simple-store-p sym form)) (cl-subst val sym form) `(let ((,sym ,val)) ,form)))) (defun cl-setf-simple-store-p (sym form) - (and (consp form) (eq (cl-expr-contains form sym) 1) + (and (consp form) (eq (cl--expr-contains form sym) 1) (eq (nth (1- (length form)) form) sym) (symbolp (car form)) (fboundp (car form)) (not (eq (car-safe (symbol-function (car form))) 'macro)))) @@ -2315,7 +2303,7 @@ (declare (debug cl-setf)) (let ((p args) (simple t) (vars nil)) (while p - (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars)) + (if (or (not (symbolp (car p))) (cl--expr-depends-p (nth 1 p) vars)) (setq simple nil)) (if (memq (car p) vars) (error "Destination duplicated in psetf: %s" (car p))) @@ -2332,7 +2320,7 @@ ;;;###autoload (defun cl-do-pop (place) - (if (cl-simple-expr-p place) + (if (cl--simple-expr-p place) `(prog1 (car ,place) (cl-setf ,place (cdr ,place))) (let* ((method (cl-setf-do-modify place t)) (temp (make-symbol "--cl-pop--"))) @@ -2348,8 +2336,8 @@ The form returns true if TAG was found and removed, nil otherwise." (declare (debug (place form))) (let* ((method (cl-setf-do-modify place t)) - (tag-temp (and (not (cl-const-expr-p tag)) (make-symbol "--cl-remf-tag--"))) - (val-temp (and (not (cl-simple-expr-p place)) + (tag-temp (and (not (macroexp-const-p tag)) (make-symbol "--cl-remf-tag--"))) + (val-temp (and (not (cl--simple-expr-p place)) (make-symbol "--cl-remf-place--"))) (ttag (or tag-temp tag)) (tval (or val-temp (nth 2 method)))) @@ -2431,7 +2419,7 @@ (save (make-symbol "--cl-letf-save--")) (bound (and (memq (car place) '(symbol-value symbol-function)) (make-symbol "--cl-letf-bound--"))) - (temp (and (not (cl-const-expr-p value)) (cdr bindings) + (temp (and (not (macroexp-const-p value)) (cdr bindings) (make-symbol "--cl-letf-val--")))) (setq lets (nconc (car method) (if bound @@ -2506,10 +2494,10 @@ \(fn FUNC ARG1 PLACE ARGS...)" (declare (indent 3) (debug (cl-function form place &rest form))) - (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) + (if (and (cl--safe-expr-p arg1) (cl--simple-expr-p place) (symbolp func)) `(cl-setf ,place (,func ,arg1 ,place ,@args)) (let* ((method (cl-setf-do-modify place (cons 'list args))) - (temp (and (not (cl-const-expr-p arg1)) (make-symbol "--cl-arg1--"))) + (temp (and (not (macroexp-const-p arg1)) (make-symbol "--cl-arg1--"))) (rargs (cl-list* (or temp arg1) (nth 2 method) args))) `(let* (,@(and temp (list (list temp arg1))) ,@(car method)) ,(cl-setf-do-store (nth 1 method) @@ -2530,7 +2518,7 @@ ,doc (,(if (memq '&rest arglist) #'cl-list* #'list) #'cl-callf ',func ,place - ,@(cl-arglist-args arglist))))) + ,@(cl--arglist-args arglist))))) ;;; Structures. @@ -2715,7 +2703,7 @@ (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))))) forms) (push (cons accessor t) side-eff) - (push `(cl-define-setf-method ,accessor (cl-x) + (push `(cl-define-setf-expander ,accessor (cl-x) ,(if (cadr (memq :read-only (cddr desc))) `(progn (ignore cl-x) (error "%s is a read-only slot" @@ -2756,13 +2744,13 @@ (while constrs (let* ((name (caar constrs)) (args (cadr (pop constrs))) - (anames (cl-arglist-args args)) + (anames (cl--arglist-args args)) (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) (push `(cl-defsubst ,name (&cl-defs '(nil ,@descs) ,@args) (,type ,@make)) forms) - (if (cl-safe-expr-p `(progn ,@(mapcar #'cl-second descs))) + (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) (push (cons name t) side-eff)))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) (if print-func @@ -2816,13 +2804,13 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (declare (debug cl-defmacro) (doc-string 3)) `(cl-eval-when (compile load eval) - ,(cl-transform-function-property + ,(cl--transform-function-property name 'cl-deftype-handler (cons `(&cl-defs '('*) ,@arglist) body)))) -(defun cl-make-type-test (val type) +(defun cl--make-type-test (val type) (if (symbolp type) (cond ((get type 'cl-deftype-handler) - (cl-make-type-test val (funcall (get type 'cl-deftype-handler)))) + (cl--make-type-test val (funcall (get type 'cl-deftype-handler)))) ((memq type '(nil t)) type) ((eq type 'null) `(null ,val)) ((eq type 'atom) `(atom ,val)) @@ -2837,10 +2825,10 @@ (if (fboundp namep) (list namep val) (list (intern (concat name "-p")) val))))) (cond ((get (car type) 'cl-deftype-handler) - (cl-make-type-test val (apply (get (car type) 'cl-deftype-handler) + (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler) (cdr type)))) ((memq (car type) '(integer float real number)) - (delq t `(and ,(cl-make-type-test val (car type)) + (delq t `(and ,(cl--make-type-test val (car type)) ,(if (memq (cadr type) '(* nil)) t (if (consp (cadr type)) `(> ,val ,(cl-caadr type)) `(>= ,val ,(cadr type)))) @@ -2849,7 +2837,7 @@ `(<= ,val ,(cl-caddr type))))))) ((memq (car type) '(and or not)) (cons (car type) - (mapcar (function (lambda (x) (cl-make-type-test val x))) + (mapcar (function (lambda (x) (cl--make-type-test val x))) (cdr type)))) ((memq (car type) '(member cl-member)) `(and (cl-member ,val ',(cdr type)) t)) @@ -2860,7 +2848,7 @@ (defun cl-typep (object type) ; See compiler macro below. "Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier." - (eval (cl-make-type-test 'object type))) + (eval (cl--make-type-test 'object type))) ;;;###autoload (defmacro cl-check-type (form type &optional string) @@ -2869,9 +2857,9 @@ (declare (debug (place cl-type-spec &optional stringp))) (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) - (let* ((temp (if (cl-simple-expr-p form 3) + (let* ((temp (if (cl--simple-expr-p form 3) form (make-symbol "--cl-var--"))) - (body `(or ,(cl-make-type-test temp type) + (body `(or ,(cl--make-type-test temp type) (signal 'wrong-type-argument (list ,(or string `',type) ,temp ',form))))) @@ -2889,11 +2877,10 @@ (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) (let ((sargs (and show-args - (delq nil (mapcar - (lambda (x) - (unless (cl-const-expr-p x) - x)) - (cdr form)))))) + (delq nil (mapcar (lambda (x) + (unless (macroexp-const-p x) + x)) + (cdr form)))))) `(progn (or ,form ,(if string @@ -2921,7 +2908,7 @@ (while (consp p) (push (pop p) res)) (setq args (nconc (nreverse res) (and p (list '&rest p))))) `(cl-eval-when (compile load eval) - ,(cl-transform-function-property + ,(cl--transform-function-property func 'compiler-macro (cons (if (memq '&whole args) (delq '&whole args) (cons '_cl-whole-arg args)) body)) @@ -2948,18 +2935,13 @@ (not (eq form (setq form (apply handler form (cdr form)))))))) form) -(defun cl-byte-compile-compiler-macro (form) - (if (eq form (setq form (cl-compiler-macroexpand form))) - (byte-compile-normal-call form) - (byte-compile-form form))) - ;; Optimize away unused block-wrappers. -(defvar cl-active-block-names nil) +(defvar cl--active-block-names nil) (cl-define-compiler-macro cl-block-wrapper (cl-form) (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil)) - (cl-active-block-names (cons cl-entry cl-active-block-names)) + (cl--active-block-names (cons cl-entry cl--active-block-names)) (cl-body (macroexpand-all ;Performs compiler-macro expansions. (cons 'progn (cddr cl-form)) macroexpand-all-environment))) @@ -2970,7 +2952,7 @@ cl-body))) (cl-define-compiler-macro cl-block-throw (cl-tag cl-value) - (let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names))) + (let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names))) (if cl-found (setcdr cl-found t))) `(throw ,cl-tag ,cl-value)) @@ -2983,10 +2965,10 @@ \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug cl-defun)) - (let* ((argns (cl-arglist-args args)) (p argns) + (let* ((argns (cl--arglist-args args)) (p argns) (pbody (cons 'progn body)) - (unsafe (not (cl-safe-expr-p pbody)))) - (while (and p (eq (cl-expr-contains args (car p)) 1)) (pop p)) + (unsafe (not (cl--safe-expr-p pbody)))) + (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p)) `(progn ,(if p nil ; give up if defaults refer to earlier args `(cl-define-compiler-macro ,name @@ -3005,12 +2987,12 @@ (cl-defun ,name ,args ,@body)))) (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) - (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole - (if (cl-simple-exprs-p argvs) (setq simple t)) + (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole + (if (cl--simple-exprs-p argvs) (setq simple t)) (let* ((substs ()) (lets (delq nil (cl-mapcar (lambda (argn argv) - (if (or simple (cl-const-expr-p argv)) + (if (or simple (macroexp-const-p argv)) (progn (push (cons argn argv) substs) (and unsafe (list argn argv))) (list argn argv))) @@ -3033,22 +3015,22 @@ (put 'eql 'byte-compile nil) (cl-define-compiler-macro eql (&whole form a b) - (cond ((eq (cl-const-expr-p a) t) - (let ((val (cl-const-expr-val a))) - (if (and (numberp val) (not (integerp val))) - `(equal ,a ,b) - `(eq ,a ,b)))) - ((eq (cl-const-expr-p b) t) - (let ((val (cl-const-expr-val b))) - (if (and (numberp val) (not (integerp val))) - `(equal ,a ,b) - `(eq ,a ,b)))) - ((cl-simple-expr-p a 5) + (cond ((macroexp-const-p a) + (let ((val (cl--const-expr-val a))) + (if (and (numberp val) (not (integerp val))) + `(equal ,a ,b) + `(eq ,a ,b)))) + ((macroexp-const-p b) + (let ((val (cl--const-expr-val b))) + (if (and (numberp val) (not (integerp val))) + `(equal ,a ,b) + `(eq ,a ,b)))) + ((cl--simple-expr-p a 5) `(if (numberp ,a) (equal ,a ,b) (eq ,a ,b))) - ((and (cl-safe-expr-p a) - (cl-simple-expr-p b 5)) + ((and (cl--safe-expr-p a) + (cl--simple-expr-p b 5)) `(if (numberp ,b) (equal ,a ,b) (eq ,a ,b))) @@ -3056,7 +3038,7 @@ (cl-define-compiler-macro cl-member (&whole form a list &rest keys) (let ((test (and (= (length keys) 2) (eq (car keys) :test) - (cl-const-expr-val (nth 1 keys))))) + (cl--const-expr-val (nth 1 keys))))) (cond ((eq test 'eq) `(memq ,a ,list)) ((eq test 'equal) `(member ,a ,list)) ((or (null keys) (eq test 'eql)) `(memql ,a ,list)) @@ -3064,16 +3046,16 @@ (cl-define-compiler-macro cl-assoc (&whole form a list &rest keys) (let ((test (and (= (length keys) 2) (eq (car keys) :test) - (cl-const-expr-val (nth 1 keys))))) + (cl--const-expr-val (nth 1 keys))))) (cond ((eq test 'eq) `(assq ,a ,list)) ((eq test 'equal) `(assoc ,a ,list)) - ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql))) - (if (cl-floatp-safe (cl-const-expr-val a)) + ((and (macroexp-const-p a) (or (null keys) (eq test 'eql))) + (if (cl-floatp-safe (cl--const-expr-val a)) `(assoc ,a ,list) `(assq ,a ,list))) (t form)))) (cl-define-compiler-macro cl-adjoin (&whole form a list &rest keys) - (if (and (cl-simple-expr-p a) (cl-simple-expr-p list) + (if (and (cl--simple-expr-p a) (cl--simple-expr-p list) (not (memq :key keys))) `(if (cl-member ,a ,list ,@keys) ,list (cons ,a ,list)) form)) @@ -3091,10 +3073,10 @@ `(get ,sym ,prop))) (cl-define-compiler-macro cl-typep (&whole form val type) - (if (cl-const-expr-p type) - (let ((res (cl-make-type-test val (cl-const-expr-val type)))) - (if (or (memq (cl-expr-contains res val) '(nil 1)) - (cl-simple-expr-p val)) res + (if (macroexp-const-p type) + (let ((res (cl--make-type-test val (cl--const-expr-val type)))) + (if (or (memq (cl--expr-contains res val) '(nil 1)) + (cl--simple-expr-p val)) res (let ((temp (make-symbol "--cl-var--"))) `(let ((,temp ,val)) ,(cl-subst temp val res))))) form)) === modified file 'lisp/emacs-lisp/cl.el' --- lisp/emacs-lisp/cl.el 2012-06-05 15:41:12 +0000 +++ lisp/emacs-lisp/cl.el 2012-06-07 19:25:48 +0000 @@ -219,8 +219,8 @@ setf get-setf-method defsetf + (define-setf-method . cl-define-setf-expander) define-setf-expander - define-setf-method declare the locally === modified file 'lisp/emacs-lisp/disass.el' --- lisp/emacs-lisp/disass.el 2012-01-19 07:21:25 +0000 +++ lisp/emacs-lisp/disass.el 2012-06-07 19:25:48 +0000 @@ -35,6 +35,8 @@ ;;; Code: +(require 'macroexp) + ;;; The variable byte-code-vector is defined by the new bytecomp.el. ;;; The function byte-decompile-lapcode is defined in byte-opt.el. ;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. @@ -155,7 +157,7 @@ (t (insert "Uncompiled body: ") (let ((print-escape-newlines t)) - (prin1 (if (cdr obj) (cons 'progn obj) (car obj)) + (prin1 (macroexp-progn obj) (current-buffer)))))) (if interactive-p (message ""))) === modified file 'lisp/emacs-lisp/edebug.el' --- lisp/emacs-lisp/edebug.el 2012-05-27 09:45:54 +0000 +++ lisp/emacs-lisp/edebug.el 2012-06-07 19:25:48 +0000 @@ -51,6 +51,8 @@ ;;; Code: +(require 'macroexp) + ;;; Bug reporting (defalias 'edebug-submit-bug-report 'report-emacs-bug) @@ -1251,10 +1253,7 @@ ((eq 'edebug-after (car sexp)) (nth 3 sexp)) ((eq 'edebug-enter (car sexp)) - (let ((forms (nthcdr 2 (nth 1 (nth 3 sexp))))) - (if (> (length forms) 1) - (cons 'progn forms) ;; could return (values forms) instead. - (car forms)))) + (macroexp-progn (nthcdr 2 (nth 1 (nth 3 sexp))))) (t sexp);; otherwise it is not wrapped, so just return it. ) sexp)) === modified file 'lisp/emacs-lisp/macroexp.el' --- lisp/emacs-lisp/macroexp.el 2012-06-06 18:08:00 +0000 +++ lisp/emacs-lisp/macroexp.el 2012-06-07 19:25:48 +0000 @@ -225,6 +225,84 @@ (let ((macroexpand-all-environment environment)) (macroexp--expand-all form))) +;;; Handy functions to use in macros. + +(defun macroexp-progn (exps) + "Return an expression equivalent to `(progn ,@EXPS)." + (if (cdr exps) `(progn ,@exps) (car exps))) + +(defun macroexp-let* (bindings exp) + "Return an expression equivalent to `(let* ,bindings ,exp)." + (cond + ((null bindings) exp) + ((eq 'let* (car-safe exp)) `(let* (,@bindings ,@(cadr exp)) ,@(cddr exp))) + (t `(let* ,bindings ,exp)))) + +(defun macroexp-if (test then else) + "Return an expression equivalent to `(if ,test ,then ,else)." + (cond + ((eq (car-safe else) 'if) + (if (equal test (nth 1 else)) + ;; Doing a test a second time: get rid of the redundancy. + `(if ,test ,then ,@(nthcdr 3 else)) + `(cond (,test ,then) + (,(nth 1 else) ,(nth 2 else)) + (t ,@(nthcdr 3 else))))) + ((eq (car-safe else) 'cond) + `(cond (,test ,then) + ;; Doing a test a second time: get rid of the redundancy, as above. + ,@(remove (assoc test else) (cdr else)))) + ;; Invert the test if that lets us reduce the depth of the tree. + ((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then)) + (t `(if ,test ,then ,else)))) + +(defmacro macroexp-let² (test var exp &rest exps) + "Bind VAR to a copyable expression that returns the value of EXP. +This is like `(let ((v ,EXP)) ,EXPS) except that `v' is a new generated +symbol which EXPS can find in VAR. +TEST should be the name of a predicate on EXP checking whether the `let' can +be skipped; if nil, as is usual, `macroexp-const-p' is used." + (declare (indent 3) (debug (sexp form sexp body))) + (let ((bodysym (make-symbol "body")) + (expsym (make-symbol "exp"))) + `(let* ((,expsym ,exp) + (,var (if (,(or test #'macroexp-const-p) ,expsym) + ,expsym (make-symbol "x"))) + (,bodysym ,(macroexp-progn exps))) + (if (eq ,var ,expsym) ,bodysym + (macroexp-let* (list (list ,var ,expsym)) + ,bodysym))))) + +(defsubst macroexp--const-symbol-p (symbol &optional any-value) + "Non-nil if SYMBOL is constant. +If ANY-VALUE is nil, only return non-nil if the value of the symbol is the +symbol itself." + (or (memq symbol '(nil t)) + (keywordp symbol) + (if any-value + (or (memq symbol byte-compile-const-variables) + ;; FIXME: We should provide a less intrusive way to find out + ;; if a variable is "constant". + (and (boundp symbol) + (condition-case nil + (progn (set symbol (symbol-value symbol)) nil) + (setting-constant t))))))) + +(defun macroexp-const-p (exp) + "Return non-nil if EXP will always evaluate to the same value." + (cond ((consp exp) (or (eq (car exp) 'quote) + (and (eq (car exp) 'function) + (symbolp (cadr exp))))) + ;; It would sometimes make sense to pass `any-value', but it's not + ;; always safe since a "constant" variable may not actually always have + ;; the same value. + ((symbolp exp) (macroexp--const-symbol-p exp)) + (t t))) + +(defun macroexp-copyable-p (exp) + "Return non-nil if EXP can be copied without extra cost." + (or (symbolp exp) (macroexp-const-p exp))) + (provide 'macroexp) ;;; macroexp.el ends here === modified file 'lisp/emacs-lisp/pcase.el' --- lisp/emacs-lisp/pcase.el 2012-05-29 14:28:02 +0000 +++ lisp/emacs-lisp/pcase.el 2012-06-07 19:25:48 +0000 @@ -53,6 +53,8 @@ ;;; Code: +(require 'macroexp) + ;; Macro-expansion of pcase is reasonably fast, so it's not a problem ;; when byte-compiling a file, but when interpreting the code, if the pcase ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we @@ -94,7 +96,7 @@ E.g. you can match pairs where the cdr is larger than the car with a pattern like `(,a . ,(pred (< a))) or, with more checks: `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" - (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars. + (declare (indent 1) (debug cl-case)) ;FIXME: edebug `guard' and vars. ;; We want to use a weak hash table as a cache, but the key will unavoidably ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time ;; we're called so it'll be immediately GC'd. So we use (car cases) as key @@ -225,10 +227,10 @@ (cdr case)))) cases)))) (if (null defs) main - (pcase--let* defs main)))) + (macroexp-let* defs main)))) (defun pcase-codegen (code vars) - ;; Don't use let*, otherwise pcase--let* may merge it with some surrounding + ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy ;; codegen from later metamorphosing this let into a funcall. `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) @@ -248,30 +250,7 @@ (cond ((eq else :pcase--dontcare) then) ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen? - ((eq (car-safe else) 'if) - (if (equal test (nth 1 else)) - ;; Doing a test a second time: get rid of the redundancy. - ;; FIXME: ideally, this should never happen because the pcase--split-* - ;; funs should have eliminated such things, but pcase--split-member - ;; is imprecise, so in practice it can happen occasionally. - `(if ,test ,then ,@(nthcdr 3 else)) - `(cond (,test ,then) - (,(nth 1 else) ,(nth 2 else)) - (t ,@(nthcdr 3 else))))) - ((eq (car-safe else) 'cond) - `(cond (,test ,then) - ;; Doing a test a second time: get rid of the redundancy, as above. - ,@(remove (assoc test else) (cdr else)))) - ;; Invert the test if that lets us reduce the depth of the tree. - ((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then)) - (t `(if ,test ,then ,else)))) - -;; Again, try and reduce nesting. -(defun pcase--let* (binders body) - (if (eq (car-safe body) 'let*) - `(let* ,(append binders (nth 1 body)) - ,@(nthcdr 2 body)) - `(let* ,binders ,body))) + (t (macroexp-if test then else)))) (defun pcase--upat (qpattern) (cond @@ -589,21 +568,17 @@ ;; A upat of the form (let VAR EXP). ;; (pcase--u1 matches code ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest) - (let* ((exp - (let* ((exp (nth 2 upat)) - (found (assq exp vars))) - (if found (cdr found) - (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) - (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) - vs))) - (if env `(let* ,env ,exp) exp))))) - (sym (if (symbolp exp) exp (make-symbol "x"))) - (body - (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) - code vars rest))) - (if (eq sym exp) - body - `(let* ((,sym ,exp)) ,body)))) + (macroexp-let² + macroexp-copyable-p sym + (let* ((exp (nth 2 upat)) + (found (assq exp vars))) + (if found (cdr found) + (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) + (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) + vs))) + (if env (macroexp-let* env exp) exp)))) + (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) + code vars rest))) ((eq (car-safe upat) '\`) (put sym 'pcase-used t) (pcase--q1 sym (cadr upat) matches code vars rest)) @@ -695,7 +670,7 @@ ;; can't signal errors and our byte-compiler is not that clever. ;; FIXME: Some of those let bindings occur too early (they are used in ;; `then-body', but only within some sub-branch). - (pcase--let* + (macroexp-let* `(,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) then-body) === modified file 'lisp/international/mule-cmds.el' --- lisp/international/mule-cmds.el 2012-04-15 07:28:01 +0000 +++ lisp/international/mule-cmds.el 2012-06-07 19:25:48 +0000 @@ -30,8 +30,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) ; letf - (defvar dos-codepage) (autoload 'widget-value "wid-edit") @@ -285,7 +283,7 @@ "Display the HELLO file, which lists many languages and characters." (interactive) ;; We have to decode the file in any environment. - (letf ((coding-system-for-read 'iso-2022-7bit)) + (let ((coding-system-for-read 'iso-2022-7bit)) (view-file (expand-file-name "HELLO" data-directory)))) (defun universal-coding-system-argument (coding-system) ------------------------------------------------------------ revno: 108512 committer: Stefan Monnier branch nick: trunk timestamp: Thu 2012-06-07 12:35:00 -0400 message: * tmm.el (tmm-prompt): Use string-prefix-p. (tmm-completion-delete-prompt): Don't affect current-buffer outside. (tmm-add-prompt): Use minibuffer-completion-help. (tmm-delete-map): Remove. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-07 16:20:28 +0000 +++ lisp/ChangeLog 2012-06-07 16:35:00 +0000 @@ -1,5 +1,10 @@ 2012-06-07 Stefan Monnier + * tmm.el (tmm-prompt): Use string-prefix-p. + (tmm-completion-delete-prompt): Don't affect current-buffer outside. + (tmm-add-prompt): Use minibuffer-completion-help. + (tmm-delete-map): Remove. + * subr.el (kbd): Make it its own function. 2012-06-07 Stefan Merten === modified file 'lisp/tmm.el' --- lisp/tmm.el 2012-04-10 20:12:07 +0000 +++ lisp/tmm.el 2012-06-07 16:35:00 +0000 @@ -229,8 +229,7 @@ (- (* 2 history-len) index-of-default)))))))) (setq choice (cdr (assoc out tmm-km-list))) (and (null choice) - (> (length out) (length tmm-c-prompt)) - (string= (substring out 0 (length tmm-c-prompt)) tmm-c-prompt) + (string-prefix-p tmm-c-prompt out) (setq out (substring out (length tmm-c-prompt)) choice (cdr (assoc out tmm-km-list)))) (and (null choice) out @@ -330,9 +329,9 @@ (use-local-map (append map (current-local-map)))))) (defun tmm-completion-delete-prompt () - (set-buffer standard-output) + (with-current-buffer standard-output (goto-char (point-min)) - (delete-region (point) (search-forward "Possible completions are:\n"))) + (delete-region (point) (search-forward "Possible completions are:\n")))) (defun tmm-remove-inactive-mouse-face () "Remove the mouse-face property from inactive menu items." @@ -351,38 +350,24 @@ (set-buffer-modified-p nil))) (defun tmm-add-prompt () - (add-hook 'minibuffer-exit-hook 'tmm-delete-map nil t) (unless tmm-c-prompt (error "No active menu entries")) (setq tmm-old-mb-map (tmm-define-keys t)) ;; Get window and hide it for electric mode to get correct size - (save-window-excursion - (let ((completions - (mapcar 'car minibuffer-completion-table))) - (or tmm-completion-prompt - (add-hook 'completion-setup-hook - 'tmm-completion-delete-prompt 'append)) - (unwind-protect - (with-output-to-temp-buffer "*Completions*" - (display-completion-list completions)) - (remove-hook 'completion-setup-hook 'tmm-completion-delete-prompt))) - (set-buffer "*Completions*") + (or tmm-completion-prompt + (add-hook 'completion-setup-hook + 'tmm-completion-delete-prompt 'append)) + (unwind-protect + (minibuffer-completion-help) + (remove-hook 'completion-setup-hook 'tmm-completion-delete-prompt)) + (with-current-buffer "*Completions*" (tmm-remove-inactive-mouse-face) (when tmm-completion-prompt - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (insert tmm-completion-prompt)))) - (save-selected-window - (other-window 1) ; Electric-pop-up-window does - ; not work in minibuffer - (Electric-pop-up-window "*Completions*")) + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (insert tmm-completion-prompt)))) (insert tmm-c-prompt)) -(defun tmm-delete-map () - (remove-hook 'minibuffer-exit-hook 'tmm-delete-map t) - (if tmm-old-mb-map - (use-local-map tmm-old-mb-map))) - (defun tmm-shortcut () "Choose the shortcut that the user typed." (interactive) @@ -520,6 +505,10 @@ (progn ;; Otherwise, it is a prefix, so make a list of the subcommands. ;; Make a list of all the bindings in all the keymaps. + ;; FIXME: we'd really like to just use `key-binding' now that it + ;; returns a keymap that contains really all the bindings under that + ;; prefix, but `keyseq' is always [menu-bar], so the desired order of + ;; the bindings is difficult to recover. (setq minorbind (mapcar 'cdr (minor-mode-key-binding keyseq))) (setq localbind (local-key-binding keyseq)) (setq globalbind (copy-sequence (cdr (global-key-binding keyseq)))) ------------------------------------------------------------ revno: 108511 committer: Stefan Monnier branch nick: trunk timestamp: Thu 2012-06-07 12:20:28 -0400 message: * subr.el (kbd): Make it its own function. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-07 09:20:41 +0000 +++ lisp/ChangeLog 2012-06-07 16:20:28 +0000 @@ -1,18 +1,17 @@ +2012-06-07 Stefan Monnier + + * subr.el (kbd): Make it its own function. + 2012-06-07 Stefan Merten * textmodes/rst.el: Use `eval-when-compile' for requiring `cl.el'. Silence compiler warnings. Fix versions. - - (rst-position-if, rst-position, rst-some, rst-signum): New - functions. + (rst-position-if, rst-position, rst-some, rst-signum): New functions. (rst-shift-region, rst-adornment-level, rst-compute-tabs) - (rst-indent-line, rst-shift-region, rst-forward-line): Use new - functions. - + (rst-indent-line, rst-shift-region, rst-forward-line): Use them. (rst-package-emacs-version-alist): Correct Emacs version to represent major merge with upstream. - (rst-transition, rst-adornment, rst-compile-toolsets): Fix - versions. + (rst-transition, rst-adornment, rst-compile-toolsets): Fix versions. 2012-06-06 Glenn Morris === modified file 'lisp/subr.el' --- lisp/subr.el 2012-06-02 10:56:09 +0000 +++ lisp/subr.el 2012-06-07 16:20:28 +0000 @@ -525,7 +525,13 @@ ;;;; Keymap support. -(defalias 'kbd 'read-kbd-macro) +(defun kbd (keys) + "Convert KEYS to the internal Emacs key representation. +KEYS should be a string constant in the format used for +saving keyboard macros (see `edmacro-mode')." + ;; Don't use a defalias, since the `pure' property is only true for + ;; the calling convention of `kbd'. + (read-kbd-macro keys)) (put 'kbd 'pure t) (defun undefined () ------------------------------------------------------------ revno: 108510 committer: Chong Yidong branch nick: trunk timestamp: Thu 2012-06-07 22:39:28 +0800 message: Add NEWS item about Buffer Menu rewrite. diff: === modified file 'etc/NEWS' --- etc/NEWS 2012-06-06 15:13:15 +0000 +++ etc/NEWS 2012-06-07 14:39:28 +0000 @@ -205,6 +205,12 @@ **** The old options whose values specified faces to use were removed (i.e. `apropos-symbol-face', `apropos-keybinding-face', etc.). +** Buffer Menu +This package has been rewritten to use Tabulated List mode. + +*** Option `Buffer-menu-buffer+size-width' is now obsolete. +Use `Buffer-menu-name-width' and `Buffer-menu-size-width' instead. + ** Calendar *** The calendars produced by cal-html include holidays. ------------------------------------------------------------ revno: 108509 committer: Stefan Merten branch nick: trunk timestamp: Thu 2012-06-07 11:20:41 +0200 message: * rst.el: Use `eval-when-compile' for requiring `cl.el'. Silence compiler warnings. Fix versions. (rst-position-if, rst-position, rst-some, rst-signum): New functions. (rst-shift-region, rst-adornment-level, rst-compute-tabs) (rst-indent-line, rst-shift-region, rst-forward-line): Use new functions. (rst-package-emacs-version-alist): Correct Emacs version to represent major merge with upstream. (rst-transition, rst-adornment, rst-compile-toolsets): Fix versions. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-06-06 18:13:09 +0000 +++ lisp/ChangeLog 2012-06-07 09:20:41 +0000 @@ -1,3 +1,19 @@ +2012-06-07 Stefan Merten + + * textmodes/rst.el: Use `eval-when-compile' for requiring `cl.el'. + Silence compiler warnings. Fix versions. + + (rst-position-if, rst-position, rst-some, rst-signum): New + functions. + (rst-shift-region, rst-adornment-level, rst-compute-tabs) + (rst-indent-line, rst-shift-region, rst-forward-line): Use new + functions. + + (rst-package-emacs-version-alist): Correct Emacs version to + represent major merge with upstream. + (rst-transition, rst-adornment, rst-compile-toolsets): Fix + versions. + 2012-06-06 Glenn Morris * mail/emacsbug.el (report-emacs-bug): Add relevant EMACS env-vars. === modified file 'lisp/textmodes/rst.el' --- lisp/textmodes/rst.el 2012-06-03 17:20:24 +0000 +++ lisp/textmodes/rst.el 2012-06-07 09:20:41 +0000 @@ -103,14 +103,58 @@ ;;; Code: -;; FIXME: Use `eval-when-compile' when calls to `some', `position', `signum' -;; and `position-if' are replaced. `catch' and `throw' may help with the -;; list operations. -(require 'cl) +;; Only use of macros is allowed - may be replaced by `cl-lib' some time. +(eval-when-compile + (require 'cl)) + +;; Redefine some functions from `cl.el' in a proper namespace until they may be +;; used from there. + +(defun rst-signum (x) + "Return 1 if X is positive, -1 if negative, 0 if zero." + (cond + ((> x 0) 1) + ((< x 0) -1) + (t 0))) + +(defun rst-some (seq &optional pred) + "Return non-nil if any element of SEQ yields non-nil when PRED is applied. +Apply PRED to each element of list SEQ until the first non-nil +result is yielded and return this result. PRED defaults to +`identity'." + (unless pred + (setq pred 'identity)) + (catch 'rst-some + (dolist (elem seq) + (let ((r (funcall pred elem))) + (when r + (throw 'rst-some r)))))) + +(defun rst-position-if (pred seq) + "Return position of first element satisfying PRED in list SEQ or nil." + (catch 'rst-position-if + (let ((i 0)) + (dolist (elem seq) + (when (funcall pred elem) + (throw 'rst-position-if i)) + (incf i))))) + +(defun rst-position (elem seq) + "Return position of ELEM in list SEQ or nil. +Comparison done with `equal'." + ;; Create a closure containing `elem' so the `lambda' always sees our + ;; parameter instead of an `elem' which may be in dynamic scope at the time + ;; of execution of the `lambda'. + (lexical-let ((elem elem)) + (rst-position-if (function (lambda (e) + (equal elem e))) + seq))) ;; FIXME: Check whether complicated `defconst's can be embedded in ;; `eval-when-compile'. +;; FIXME: Check whether `lambda's can be embedded in `function'. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Versions @@ -127,7 +171,7 @@ ;; Use CVSHeader to really get information from CVS and not other version ;; control systems. (defconst rst-cvs-header - "$CVSHeader: sm/rst_el/rst.el,v 1.273 2012-06-03 17:01:33 stefan Exp $") + "$CVSHeader: sm/rst_el/rst.el,v 1.282 2012-06-06 19:16:55 stefan Exp $") (defconst rst-cvs-rev (rst-extract-version "\\$" "CVSHeader: \\S + " "[0-9]+\\(?:\\.[0-9]+\\)+" " .*" rst-cvs-header "0.0") @@ -170,10 +214,11 @@ in parentheses follows the development revision and the time stamp.") (defconst rst-package-emacs-version-alist - '(("1.0.0" . "24.0") - ("1.1.0" . "24.0") - ("1.2.0" . "24.0") - ("1.2.1" . "24.0"))) + '(("1.0.0" . "24.2") + ("1.1.0" . "24.2") + ("1.2.0" . "24.2") + ("1.2.1" . "24.2") + ("1.3.0" . "24.2"))) (unless (assoc rst-official-version rst-package-emacs-version-alist) (error "Version %s not listed in `rst-package-emacs-version-alist'" @@ -431,6 +476,8 @@ Each entry consists of the symbol naming the regex and an argument list for `rst-re'.") +(defvar rst-re-alist) ; Forward declare to use it in `rst-re'. + ;; FIXME: Use `sregex` or `rx` instead of re-inventing the wheel. (defun rst-re (&rest args) "Interpret ARGS as regular expressions and return a regex string. @@ -490,16 +537,16 @@ args))) ;; FIXME: Remove circular dependency between `rst-re' and `rst-re-alist'. -(defconst rst-re-alist - ;; Shadow global value we are just defining so we can construct it step by - ;; step. - (let (rst-re-alist) - (dolist (re rst-re-alist-def) - (setq rst-re-alist - (nconc rst-re-alist - (list (list (car re) (apply 'rst-re (cdr re))))))) - rst-re-alist) - "Alist mapping symbols from `rst-re-alist-def' to regex strings.") +(with-no-warnings ; Silence byte-compiler about this construction. + (defconst rst-re-alist + ;; Shadow global value we are just defining so we can construct it step by + ;; step. + (let (rst-re-alist) + (dolist (re rst-re-alist-def rst-re-alist) + (setq rst-re-alist + (nconc rst-re-alist + (list (list (car re) (apply 'rst-re (cdr re)))))))) + "Alist mapping symbols from `rst-re-alist-def' to regex strings.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -683,6 +730,8 @@ :group 'rst :type '(hook)) +;; Pull in variable definitions silencing byte-compiler. +(require 'newcomment) ;; Use rst-mode for *.rst and *.rest files. Many ReStructured-Text files ;; use *.txt, but this is too generic to be set as a default. @@ -856,9 +905,8 @@ :group 'rst :version "21.1") -;; FIXME: The version must be represented in `rst-package-emacs-version-alist'. (define-obsolete-variable-alias - 'rst-preferred-decorations 'rst-preferred-adornments "r6506") + 'rst-preferred-decorations 'rst-preferred-adornments "1.0.0") (defcustom rst-preferred-adornments '((?= over-and-under 1) (?= simple 0) (?- simple 0) @@ -1743,11 +1791,6 @@ )) ))) -(defun rst-position (elem list) - "Return position of ELEM in LIST or nil." - (let ((tail (member elem list))) - (if tail (- (length list) (length tail))))) - (defun rst-straighten-adornments () "Redo all the adornments in the current buffer. This is done using our preferred set of adornments. This can be @@ -2763,9 +2806,8 @@ :group 'rst :package-version '(rst . "1.1.0")) -;; FIXME: The version must be represented in `rst-package-emacs-version-alist'. (define-obsolete-variable-alias - 'rst-shift-basic-offset 'rst-indent-width "r6713") + 'rst-shift-basic-offset 'rst-indent-width "1.0.0") (defcustom rst-indent-width 2 "Indentation when there is no more indentation point given." :group 'rst-indent @@ -2890,8 +2932,7 @@ (< newcol innermost)))) (not (memq newcol tablist))) (push newcol tablist)))) - (setq innermost (if (some 'identity - (mapcar 'cdr tabs)) ; Has inner. + (setq innermost (if (rst-some (mapcar 'cdr tabs)) ; Has inner. leftcol innermost)) (setq leftmost leftcol))))) @@ -2912,7 +2953,7 @@ (cur (current-indentation)) (clm (current-column)) (tabs (rst-compute-tabs (point))) - (fnd (position cur tabs)) + (fnd (rst-position cur tabs)) ind) (if (and (not tabs) (not dflt)) 'noindent @@ -2948,12 +2989,14 @@ (let* ((cmp (if (> cnt 0) '> '<)) (tabs (if (> cnt 0) tabs (reverse tabs))) (len (length tabs)) - (dir (signum cnt)) ; Direction to take. + (dir (rst-signum cnt)) ; Direction to take. (abs (abs cnt)) ; Absolute number of steps to take. ;; Get the position of the first tab beyond leftmostcol. - (fnd (position-if (lambda (elt) - (funcall cmp elt leftmostcol)) - tabs)) + (fnd (lexical-let ((cmp cmp) + (leftmostcol leftmostcol)) ; Create closure. + (rst-position-if (lambda (elt) + (funcall cmp elt leftmostcol)) + tabs))) ;; Virtual position of tab. (pos (+ (or fnd len) (1- abs))) (tab (if (< pos len) @@ -3136,8 +3179,8 @@ ;; FIXME: The obsolete variables need to disappear. -;; FIXME LEVEL-FACE: All `:version "24.1"' attributes need to be changed to -;; proper `:package-version "24.1"' attributes. +;; The following versions have been done inside Emacs and should not be +;; replaced by `:package-version' attributes until a change. (defgroup rst-faces nil "Faces used in Rst Mode." :group 'rst @@ -3273,12 +3316,12 @@ (defface rst-transition '((t :inherit font-lock-keyword-face)) "Face used for a transition." - :version "24.1" + :package-version '(rst . "1.3.0") :group 'rst-faces) (defface rst-adornment '((t :inherit font-lock-keyword-face)) "Face used for the adornment of a section header." - :version "24.1" + :package-version '(rst . "1.3.0") :group 'rst-faces) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -3646,7 +3689,7 @@ (if (bolp) moved (forward-line 0) - (- moved (signum n))))) + (- moved (rst-signum n))))) ;; FIXME: If a single line is made a section header by `rst-adjust' the header ;; is not always fontified immediately. @@ -3829,9 +3872,12 @@ (let* ((hier (rst-get-hierarchy)) (char (car key)) (style (cdr key))) - (1+ (or (position-if (lambda (elt) - (and (equal (car elt) char) - (equal (cadr elt) style))) hier) + (1+ (or (lexical-let ((char char) + (style style) + (hier hier)) ; Create closure. + (rst-position-if (lambda (elt) + (and (equal (car elt) char) + (equal (cadr elt) style))) hier)) (length hier)))))) (defvar rst-font-lock-adornment-match nil @@ -3919,7 +3965,7 @@ (const :tag "No options" nil) (string :tag "Options")))) :group 'rst - :version "24.1") + :package-version "1.2.0") ;; FIXME: Must be `defcustom`. (defvar rst-compile-primary-toolset 'html @@ -4067,7 +4113,7 @@ (defun rst-join-paragraph () "Join lines in current paragraph into one line, removing end-of-lines." (interactive) - (let ((fill-column 65000)) ; some big number. + (let ((fill-column 65000)) ; Some big number. (call-interactively 'fill-paragraph))) ;; FIXME: Unbound command - should be bound or removed. ------------------------------------------------------------ revno: 108508 committer: Paul Eggert branch nick: trunk timestamp: Wed 2012-06-06 22:11:51 -0700 message: * doprnt.c (doprnt): Truncate multibyte char correctly. Without this change, doprnt (buf, 2, "%s", FORMAT_END, AP) would mishandle a string argument "Xc" if X was a multibyte character of length 2: it would truncate after X's first byte rather than including all of X. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-06-06 06:39:24 +0000 +++ src/ChangeLog 2012-06-07 05:11:51 +0000 @@ -1,3 +1,11 @@ +2012-06-07 Paul Eggert + + * doprnt.c (doprnt): Truncate multibyte char correctly. + Without this change, doprnt (buf, 2, "%s", FORMAT_END, AP) + would mishandle a string argument "Xc" if X was a multibyte + character of length 2: it would truncate after X's first byte + rather than including all of X. + 2012-06-06 Chong Yidong * buffer.c (word_wrap): Doc fix. === modified file 'src/doprnt.c' --- src/doprnt.c 2012-02-10 18:58:48 +0000 +++ src/doprnt.c 2012-06-07 05:11:51 +0000 @@ -392,15 +392,19 @@ { /* Truncate the string at character boundary. */ tem = bufsize; - while (!CHAR_HEAD_P (string[tem - 1])) tem--; - /* If the multibyte sequence of this character is - too long for the space we have left in the - buffer, truncate before it. */ - if (tem > 0 - && BYTES_BY_CHAR_HEAD (string[tem - 1]) > bufsize) - tem--; - if (tem > 0) - memcpy (bufptr, string, tem); + do + { + tem--; + if (CHAR_HEAD_P (string[tem])) + { + if (BYTES_BY_CHAR_HEAD (string[tem]) <= bufsize - tem) + tem = bufsize; + break; + } + } + while (tem != 0); + + memcpy (bufptr, string, tem); bufptr[tem] = 0; /* Trigger exit from the loop, but make sure we return to the caller a value which will indicate