mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-06 14:30:50 -08:00
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.
This commit is contained in:
Stefan Monnier
parent
4dd1c416d1
commit
6fa6c4aedb
6 changed files with 191 additions and 210 deletions
|
|
@ -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 ""))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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" "\
|
||||
|
|
|
|||
|
|
@ -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 <val>) ...(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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue