From 6fa6c4aedbc9f33cf8ed67fdb7794c3b4ff6660a Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 7 Jun 2012 15:48:22 -0400 Subject: [PATCH] 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. --- lisp/ChangeLog | 32 ++++++++ lisp/emacs-lisp/cl-extra.el | 123 +--------------------------- lisp/emacs-lisp/cl-lib.el | 25 ------ lisp/emacs-lisp/cl-loaddefs.el | 45 +++-------- lisp/emacs-lisp/cl-macs.el | 144 ++++++++++++++++++++++++++------- lisp/emacs-lisp/cl.el | 32 ++++++++ 6 files changed, 191 insertions(+), 210 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 153fb79ef87..07b330a3e6e 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,35 @@ +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) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index db8f663a873..6c774e7e8cd 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -221,10 +221,6 @@ If so, return the true (non-nil) value returned by PREDICATE. \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 @@ Optional second arg STATE is a random-state object." "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 @@ If START or END is negative, it counts from the end." (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 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (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 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (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 "")))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index d70a98c1bc6..5cfb99bd829 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -267,29 +267,6 @@ right when EXPRESSION calls an ordinary Emacs Lisp function that returns just 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 @@ The elements of LIST are not copied, just the list structure itself." (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)) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 0e2c97f9c44..2d7c9153318 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -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 @@ Return true if PREDICATE is false of some element of SEQ or SEQs. \(fn PREDICATE SEQ...)" nil nil) -(defalias 'cl-map-keymap 'map-keymap) - (autoload 'cl-map-keymap-recursively "cl-extra" "\ @@ -248,28 +245,6 @@ Remove from SYMBOL's plist the property PROPNAME and its value. \(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 @@ This also does some trivial optimizations to make the form prettier. ;;;;;; 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" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index acb60373b5a..91d7c211483 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -310,11 +310,6 @@ its argument list allows full Common Lisp conventions." (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 @@ It is a list of elements of the form either: (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 @@ go back to their previous definitions, or lack thereof). (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 @@ Unlike `cl-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) (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 @@ Unlike `cl-flet', this macro is fully compliant with the Common Lisp standard. `(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 @@ This is like `cl-flet', but for macros instead of functions. (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 @@ by EXPANSION, and (setq NAME ...) will act like (cl-setf EXPANSION ...). \(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 @@ lexical closures as in Common Lisp. (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 @@ Example: ;; 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 @@ Example: ;;; 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 @@ Example: `(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 @@ Example: `(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 @@ Example: `(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 @@ a macro like `cl-setf' or `cl-incf'." (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 @@ a macro like `cl-setf' or `cl-incf'." (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)) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index ad15d038a81..b4be63f2bb1 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -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 -- 2.39.2