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.
This commit is contained in:
Stefan Monnier
parent
4f18a4ed84
commit
de7e2b3687
5 changed files with 271 additions and 209 deletions
|
|
@ -1,3 +1,18 @@
|
|||
2012-06-08 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
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 <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/cl.el (cl-macroexpand, cl-macro-environment)
|
||||
|
|
|
|||
|
|
@ -258,13 +258,12 @@ Remove from SYMBOL's plist the property PROPNAME and its value.
|
|||
;;;;;; 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 @@ a `let' form, except that the list of symbols can be computed at run-time.
|
|||
|
||||
(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 @@ go back to their previous definitions, or lack thereof).
|
|||
|
||||
(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 @@ by EXPANSION, and (setq NAME ...) will act like (cl-setf EXPANSION ...).
|
|||
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -1611,63 +1611,70 @@ a `let' form, except that the list of symbols can be computed at run-time."
|
|||
(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))
|
||||
|
||||
;;;###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.
|
||||
|
||||
\(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)))
|
||||
`(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.
|
||||
The bindings can be recursive. Assumes the use of `lexical-binding'.
|
||||
|
||||
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
|
||||
(declare (indent 1) (debug cl-flet))
|
||||
(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 `(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 @@ by EXPANSION, and (setq NAME ...) will act like (cl-setf EXPANSION ...).
|
|||
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 <val>) ...(symbol-value foo)...)
|
||||
;; into (let ((foo <val>)) ...(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 <val>)) ...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 @@ surrounded by (cl-block NAME ...).
|
|||
;; generated-autoload-file: "cl-loaddefs.el"
|
||||
;; End:
|
||||
|
||||
(provide 'cl-macs)
|
||||
|
||||
;;; cl-macs.el ends here
|
||||
|
|
|
|||
|
|
@ -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 <val>) ...(symbol-value foo)...)
|
||||
;; into (let ((foo <val>)) ...(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 <val>)) ...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
|
||||
|
|
|
|||
|
|
@ -231,6 +231,10 @@ definitions to shadow the loaded ones for use in file byte-compilation."
|
|||
"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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue