X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/233ba4d924933cb56129bd7511e6137b7c0b8e3e..b1f367f797aa19047904e73a67e52f391c720e0d:/lisp/emacs-lisp/cl-macs.el diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 80e95724f1..d6b4643d6a 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. @@ -1257,14 +1236,29 @@ Then evaluate RESULT to get return value, default nil. \(fn (VAR LIST [RESULT]) BODY...)" (let ((temp (make-symbol "--cl-dolist-temp--"))) - (list 'block nil - (list* 'let (list (list temp (nth 1 spec)) (car spec)) - (list* 'while temp (list 'setq (car spec) (list 'car temp)) - (append body (list (list 'setq temp - (list 'cdr temp))))) - (if (cdr (cdr spec)) - (cons (list 'setq (car spec) nil) (cdr (cdr spec))) - '(nil)))))) + ;; FIXME: Copy&pasted from subr.el. + `(block nil + ;; This is not a reliable test, but it does not matter because both + ;; semantics are acceptable, tho one is slightly faster with dynamic + ;; scoping and the other is slightly faster (and has cleaner semantics) + ;; with lexical scoping. + ,(if lexical-binding + `(let ((,temp ,(nth 1 spec))) + (while ,temp + (let ((,(car spec) (car ,temp))) + ,@body + (setq ,temp (cdr ,temp)))) + ,@(if (cdr (cdr spec)) + ;; FIXME: This let often leads to "unused var" warnings. + `((let ((,(car spec) nil)) ,@(cdr (cdr spec)))))) + `(let ((,temp ,(nth 1 spec)) + ,(car spec)) + (while ,temp + (setq ,(car spec) (car ,temp)) + ,@body + (setq ,temp (cdr ,temp))) + ,@(if (cdr (cdr spec)) + `((setq ,(car spec) nil) ,@(cddr spec)))))))) ;;;###autoload (defmacro dotimes (spec &rest body) @@ -1274,12 +1268,30 @@ to COUNT, exclusive. Then evaluate RESULT to get return value, default nil. \(fn (VAR COUNT [RESULT]) BODY...)" - (let ((temp (make-symbol "--cl-dotimes-temp--"))) - (list 'block nil - (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0)) - (list* 'while (list '< (car spec) temp) - (append body (list (list 'incf (car spec))))) - (or (cdr (cdr spec)) '(nil)))))) + (let ((temp (make-symbol "--cl-dotimes-temp--")) + (end (nth 1 spec))) + ;; FIXME: Copy&pasted from subr.el. + `(block nil + ;; This is not a reliable test, but it does not matter because both + ;; semantics are acceptable, tho one is slightly faster with dynamic + ;; scoping and the other has cleaner semantics. + ,(if lexical-binding + (let ((counter '--dotimes-counter--)) + `(let ((,temp ,end) + (,counter 0)) + (while (< ,counter ,temp) + (let ((,(car spec) ,counter)) + ,@body) + (setq ,counter (1+ ,counter))) + ,@(if (cddr spec) + ;; FIXME: This let often leads to "unused var" warnings. + `((let ((,(car spec) ,counter)) ,@(cddr spec)))))) + `(let ((,temp ,end) + (,(car spec) 0)) + (while (< ,(car spec) ,temp) + ,@body + (incf ,(car spec))) + ,@(cdr (cdr spec))))))) ;;;###autoload (defmacro do-symbols (spec &rest body) @@ -1427,7 +1439,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) @@ -1473,7 +1485,7 @@ 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 VARLIST BODY)" +\n(fn BINDINGS BODY)" (if (null bindings) (cons 'progn body) (setq bindings (reverse bindings)) (while bindings @@ -1589,6 +1601,13 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). ;;;###autoload (defmacro declare (&rest specs) + "Declare SPECS about the current function while compiling. +For instance + + \(declare (warn 0)) + +will turn off byte-compile warnings in the function. +See Info node `(cl)Declarations' for details." (if (cl-compiling-file) (while specs (if (listp cl-declare-stack) (push (car specs) cl-declare-stack)) @@ -2377,8 +2396,10 @@ value, that slot cannot be set via `setf'. (push (cons accessor t) side-eff) (push (list 'define-setf-method accessor '(cl-x) (if (cadr (memq :read-only (cddr desc))) - (list 'error (format "%s is a read-only slot" - accessor)) + (list 'progn '(ignore cl-x) + (list 'error + (format "%s is a read-only slot" + 'accessor))) ;; If cl is loaded only for compilation, ;; the call to cl-struct-setf-expander would ;; cause a warning because it may not be @@ -2422,11 +2443,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 +2603,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 +2641,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.