diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-macs.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 64 |
1 files changed, 33 insertions, 31 deletions
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c57d37703b0..9ce3dd6a7fe 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -497,7 +497,7 @@ The result of the body appears to the compiler as a quoted constant." (symbol-function 'byte-compile-file-form))) (list 'byte-compile-file-form (list 'quote set)) '(byte-compile-file-form form))) - (print set (symbol-value 'bytecomp-outbuffer))) + (print set (symbol-value 'byte-compile--outbuffer))) (list 'symbol-value (list 'quote temp))) (list 'quote (eval form)))) @@ -598,27 +598,6 @@ called from BODY." (list* 'catch (list 'quote (intern (format "--cl-block-%s--" name))) body)))) -(defvar cl-active-block-names nil) - -(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block) -(defun cl-byte-compile-block (cl-form) - (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler - (progn - (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) - (cl-active-block-names (cons cl-entry cl-active-block-names)) - (cl-body (byte-compile-top-level - (cons 'progn (cddr (nth 1 cl-form)))))) - (if (cdr cl-entry) - (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body)) - (byte-compile-form cl-body)))) - (byte-compile-form (nth 1 cl-form)))) - -(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw) -(defun cl-byte-compile-throw (cl-form) - (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names))) - (if cl-found (setcdr cl-found t))) - (byte-compile-normal-call (cons 'throw (cdr cl-form)))) - ;;;###autoload (defmacro return (&optional result) "Return from the block named nil. @@ -1427,7 +1406,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). "Like `let', but lexically scoped. The main visible difference is that lambdas inside BODY will create lexical closures as in Common Lisp. -\n(fn VARLIST BODY)" +\n(fn BINDINGS BODY)" (let* ((cl-closure-vars cl-closure-vars) (vars (mapcar (function (lambda (x) @@ -1470,10 +1449,10 @@ lexical closures as in Common Lisp. (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 VARLIST, will create lexical closures +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 VARLIST BODY)" +\n(fn BINDINGS BODY)" (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) (while bindings @@ -2422,11 +2401,13 @@ value, that slot cannot be set via `setf'. (push (cons name t) side-eff)))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) (if print-func - (push (list 'push - (list 'function - (list 'lambda '(cl-x cl-s cl-n) - (list 'and pred-form print-func))) - 'custom-print-functions) forms)) + (push `(push + ;; The auto-generated function does not pay attention to + ;; the depth argument cl-n. + (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n)) + (and ,pred-form ,print-func)) + custom-print-functions) + forms)) (push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms) (push (list* 'eval-when '(compile load eval) (list 'put (list 'quote name) '(quote cl-struct-slots) @@ -2580,7 +2561,7 @@ and then returning foo." (cl-transform-function-property func 'cl-compiler-macro (cons (if (memq '&whole args) (delq '&whole args) - (cons '--cl-whole-arg-- args)) body)) + (cons '_cl-whole-arg args)) body)) (list 'or (list 'get (list 'quote func) '(quote byte-compile)) (list 'progn (list 'put (list 'quote func) '(quote byte-compile) @@ -2618,6 +2599,27 @@ and then returning foo." (byte-compile-normal-call form) (byte-compile-form form))) +;; Optimize away unused block-wrappers. + +(defvar cl-active-block-names nil) + +(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-body (macroexpand-all ;Performs compiler-macro expansions. + (cons 'progn (cddr cl-form)) + macroexpand-all-environment))) + ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able + ;; to indicate that this return value is already fully expanded. + (if (cdr cl-entry) + `(catch ,(nth 1 cl-form) ,@(cdr cl-body)) + cl-body))) + +(define-compiler-macro cl-block-throw (cl-tag cl-value) + (let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names))) + (if cl-found (setcdr cl-found t))) + `(throw ,cl-tag ,cl-value)) + ;;;###autoload (defmacro defsubst* (name args &rest body) "Define NAME as a function. |