From 4d3b8872ad53ef6352f769df84c26b0f835ede3a Mon Sep 17 00:00:00 2001 From: Robin Templeton Date: Sun, 3 Aug 2014 02:14:36 -0400 Subject: [PATCH] evaluation time changes --- lisp/emacs-lisp/byte-run.el | 7 +- lisp/emacs-lisp/cl-macs.el | 223 +++++++++++++++++++----------------- 2 files changed, 119 insertions(+), 111 deletions(-) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index b9fc8d855d..55b508fd9f 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -193,9 +193,10 @@ The return value is undefined. (message "Warning: Unknown macro property %S in %S" (car x) name)))) decls))) - (if declarations - (cons 'prog1 (cons def declarations)) - def)))))) + (list 'eval-when '(:compile-toplevel :load-toplevel :execute) + (if declarations + (cons 'prog1 (cons def declarations)) + def))))))) ;; Now that we defined defmacro we can use it! (defmacro defun (name arglist &optional docstring &rest body) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 0a426d1709..5b608f0093 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -89,10 +89,11 @@ ;; These are used by various ;; macro expanders to optimize the results in certain common cases. -(defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max - car-safe cdr-safe progn prog1 prog2)) -(defconst cl--safe-funcs '(* / % length memq list vector vectorp - < > <= >= = error)) +(eval-and-compile + (defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max + car-safe cdr-safe progn prog1 prog2)) + (defconst cl--safe-funcs '(* / % length memq list vector vectorp + < > <= >= = error))) (defun cl--simple-expr-p (x &optional size) "Check if no side effects, and executes quickly." @@ -113,16 +114,17 @@ (setq xs (cdr xs))) (not xs)) -(defun cl--safe-expr-p (x) - "Check if no side effects." - (or (not (and (consp x) (not (memq (car x) '(quote function cl-function))))) - (and (symbolp (car x)) - (or (memq (car x) cl--simple-funcs) - (memq (car x) cl--safe-funcs) - (get (car x) 'side-effect-free)) - (progn - (while (and (setq x (cdr x)) (cl--safe-expr-p (car x)))) - (null x))))) +(eval-and-compile + (defun cl--safe-expr-p (x) + "Check if no side effects." + (or (not (and (consp x) (not (memq (car x) '(quote function cl-function))))) + (and (symbolp (car x)) + (or (memq (car x) cl--simple-funcs) + (memq (car x) cl--safe-funcs) + (get (car x) 'side-effect-free)) + (progn + (while (and (setq x (cdr x)) (cl--safe-expr-p (car x)))) + (null x)))))) ;;; Check if constant (i.e., no side effects or dependencies). (defun cl--const-expr-p (x) @@ -143,20 +145,21 @@ whether X is known at compile time, macroexpand it completely in (if (macroexp-const-p x) (if (consp x) (nth 1 x) x)))) -(defun cl--expr-contains (x y) - "Count number of times X refers to Y. Return nil for 0 times." - ;; FIXME: This is naive, and it will cl-count Y as referred twice in - ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on - ;; non-macroexpanded code, so it may also miss some occurrences that would - ;; only appear in the expanded code. - (cond ((equal y x) 1) - ((and (consp x) (not (memq (car x) '(quote function cl-function)))) - (let ((sum 0)) - (while (consp x) - (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0)))) - (setq sum (+ sum (or (cl--expr-contains x y) 0))) - (and (> sum 0) sum))) - (t nil))) +(eval-and-compile + (defun cl--expr-contains (x y) + "Count number of times X refers to Y. Return nil for 0 times." + ;; FIXME: This is naive, and it will cl-count Y as referred twice in + ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on + ;; non-macroexpanded code, so it may also miss some occurrences that would + ;; only appear in the expanded code. + (cond ((equal y x) 1) + ((and (consp x) (not (memq (car x) '(quote function cl-function)))) + (let ((sum 0)) + (while (consp x) + (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0)))) + (setq sum (+ sum (or (cl--expr-contains x y) 0))) + (and (> sum 0) sum))) + (t nil)))) (defun cl--expr-contains-any (x y) (while (and y (not (cl--expr-contains x (car y)))) (pop y)) @@ -217,71 +220,73 @@ The name is made by appending a number to PREFIX, default \"G\"." (def-edebug-spec cl-type-spec sexp) -(defconst cl--lambda-list-keywords - '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) +(eval-and-compile + (defconst cl--lambda-list-keywords + '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) -(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) -(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms) + (defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) + (defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms)) -(defun cl--transform-lambda (form bind-block) - "Transform a function form FORM of name BIND-BLOCK. +(eval-and-compile + (defun cl--transform-lambda (form bind-block) + "Transform a function form FORM of name BIND-BLOCK. BIND-BLOCK is the name of the symbol to which the function will be bound, and which will be used for the name of the `cl-block' surrounding the function's body. FORM is of the form (ARGS . BODY)." - (let* ((args (car form)) (body (cdr form)) (orig-args args) - (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) - (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) - (header nil) (simple-args nil)) - (while (or (stringp (car body)) - (memq (car-safe (car body)) '(interactive declare cl-declare))) - (push (pop body) header)) - (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) - (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) - (setq args (delq '&cl-defs (delq cl--bind-defs args)) - cl--bind-defs (cadr cl--bind-defs))) - (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)) - (env-exp 'macroexpand-all-environment)) - (if p (setq args (nconc (delq (car p) (delq v args)) - (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) - (or cl--bind-defs (consp (cadr args)))))) - (push (pop args) simple-args)) - (or (eq cl--bind-block 'cl-none) - (setq body (list `(cl-block ,cl--bind-block ,@body)))) - (if (null args) - (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) - (if (memq '&optional simple-args) (push '&optional args)) - (cl--do-arglist args nil (- (length simple-args) - (if (memq '&optional simple-args) 1 0))) - (setq cl--bind-lets (nreverse cl--bind-lets)) - (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) - ,@(nreverse cl--bind-inits))) - (nconc (nreverse simple-args) - (list '&rest (car (pop cl--bind-lets)))) - (nconc (let ((hdr (nreverse header))) - ;; Macro expansion can take place in the middle of - ;; apparently harmless computation, so it should not - ;; touch the match-data. - (save-match-data - (require 'help-fns) - (cons (help-add-fundoc-usage - (if (stringp (car hdr)) (pop hdr)) - ;; Be careful with make-symbol and (back)quote, - ;; see bug#12884. - (let ((print-gensym nil) (print-quoted t)) - (format "%S" (cons 'fn (cl--make-usage-args - orig-args))))) - hdr))) - (list `(let* ,cl--bind-lets - ,@(nreverse cl--bind-forms) - ,@body))))))) + (let* ((args (car form)) (body (cdr form)) (orig-args args) + (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) + (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) + (header nil) (simple-args nil)) + (while (or (stringp (car body)) + (memq (car-safe (car body)) '(interactive declare cl-declare))) + (push (pop body) header)) + (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) + (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) + (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) + (setq args (delq '&cl-defs (delq cl--bind-defs args)) + cl--bind-defs (cadr cl--bind-defs))) + (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)) + (env-exp 'macroexpand-all-environment)) + (if p (setq args (nconc (delq (car p) (delq v args)) + (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) + (or cl--bind-defs (consp (cadr args)))))) + (push (pop args) simple-args)) + (or (eq cl--bind-block 'cl-none) + (setq body (list `(cl-block ,cl--bind-block ,@body)))) + (if (null args) + (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) + (if (memq '&optional simple-args) (push '&optional args)) + (cl--do-arglist args nil (- (length simple-args) + (if (memq '&optional simple-args) 1 0))) + (setq cl--bind-lets (nreverse cl--bind-lets)) + (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) + ,@(nreverse cl--bind-inits))) + (nconc (nreverse simple-args) + (list '&rest (car (pop cl--bind-lets)))) + (nconc (let ((hdr (nreverse header))) + ;; Macro expansion can take place in the middle of + ;; apparently harmless computation, so it should not + ;; touch the match-data. + (save-match-data + (require 'help-fns) + (cons (help-add-fundoc-usage + (if (stringp (car hdr)) (pop hdr)) + ;; Be careful with make-symbol and (back)quote, + ;; see bug#12884. + (let ((print-gensym nil) (print-quoted t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args))))) + hdr))) + (list `(let* ,cl--bind-lets + ,@(nreverse cl--bind-forms) + ,@body)))))))) ;;;###autoload (defmacro cl-defun (name args &rest body) @@ -553,17 +558,18 @@ its argument list allows full Common Lisp conventions." (cl--do-arglist (pop args) nil)))) (if args (error "Malformed argument list %s" save-args))))) -(defun cl--arglist-args (args) - (if (nlistp args) (list args) - (let ((res nil) (kind nil) arg) - (while (consp args) - (setq arg (pop args)) - (if (memq arg cl--lambda-list-keywords) (setq kind arg) - (if (eq arg '&cl-defs) (pop args) - (and (consp arg) kind (setq arg (car arg))) - (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) - (setq res (nconc res (cl--arglist-args arg)))))) - (nconc res (and args (list args)))))) +(eval-and-compile + (defun cl--arglist-args (args) + (if (nlistp args) (list args) + (let ((res nil) (kind nil) arg) + (while (consp args) + (setq arg (pop args)) + (if (memq arg cl--lambda-list-keywords) (setq kind arg) + (if (eq arg '&cl-defs) (pop args) + (and (consp arg) kind (setq arg (car arg))) + (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) + (setq res (nconc res (cl--arglist-args arg)))))) + (nconc res (and args (list args))))))) ;;;###autoload (defmacro cl-destructuring-bind (args expr &rest body) @@ -759,16 +765,17 @@ This is compatible with Common Lisp, but note that `defun' and ;;; The "cl-loop" macro. -(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) -(defvar cl--loop-bindings) (defvar cl--loop-body) -(defvar cl--loop-finally) -(defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop? -(defvar cl--loop-first-flag) -(defvar cl--loop-initially) (defvar cl--loop-iterator-function) -(defvar cl--loop-name) -(defvar cl--loop-result) (defvar cl--loop-result-explicit) -(defvar cl--loop-result-var) (defvar cl--loop-steps) -(defvar cl--loop-symbol-macs) +(eval-and-compile + (defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) + (defvar cl--loop-bindings) (defvar cl--loop-body) + (defvar cl--loop-finally) + (defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop? + (defvar cl--loop-first-flag) + (defvar cl--loop-initially) (defvar cl--loop-iterator-function) + (defvar cl--loop-name) + (defvar cl--loop-result) (defvar cl--loop-result-explicit) + (defvar cl--loop-result-var) (defvar cl--loop-steps) + (defvar cl--loop-symbol-macs)) (defun cl--loop-set-iterator-function (kind iterator) (if cl--loop-iterator-function -- 2.20.1