From: Stefan Monnier Date: Thu, 7 Jun 2012 19:25:48 +0000 (-0400) Subject: Cleanup cl-macs namespace. Add macro helpers in macroexp.el. X-Git-Tag: emacs-24.2.90~1199^2~474^2~100 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=4dd1c416d1c17aee0558dc3c1a37549462e75526;p=emacs.git Cleanup cl-macs namespace. Add macro helpers in macroexp.el. * emacs-lisp/macroexp.el (macroexp-progn, macroexp-let*, macroexp-if) (macroexp-let², macroexp--const-symbol-p, macroexp-const-p) (macroexp-copyable-p): New functions and macros. * emacs-lisp/edebug.el (edebug-unwrap): * emacs-lisp/disass.el (disassemble-internal): Use macroexp-progn. * emacs-lisp/pcase.el: Use macroexp-let*, macroexp-if, ... (pcase--let*): Remove. * emacs-lisp/bytecomp.el (byte-compile-const-symbol-p) (byte-compile-constp): Remove. Use macroexp--const-symbol-p and macroexp-const-p instead. * emacs-lisp/byte-opt.el: Use macroexp-const-p and macroexp-progn. * emacs-lisp/cl-macs.el: Clean up the name space by using "cl--" instead of "cl-" for internal definitions. Use macroexp-const-p. (cl-old-bc-file-form): Remove var. (cl-const-exprs-p): Remove fun. (cl-labels, cl-macrolet): Use backquote. (cl-lexical-let): Use cl-symbol-macrolet. Don't use cl-defun-expander. (cl-defun-expander, cl-byte-compile-compiler-macro): Remove fun. (cl-define-setf-expander): Rename from cl-define-setf-method. * emacs-lisp/cl.el: Adjust alias for define-setf-method. * international/mule-cmds.el: Don't require CL. (view-hello-file): Don't use `letf'. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index becb266b5bd..153fb79ef87 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,30 @@ +2012-06-07 Stefan Monnier + + * emacs-lisp/macroexp.el (macroexp-progn, macroexp-let*, macroexp-if) + (macroexp-let², macroexp--const-symbol-p, macroexp-const-p) + (macroexp-copyable-p): New functions and macros. + * emacs-lisp/edebug.el (edebug-unwrap): + * emacs-lisp/disass.el (disassemble-internal): Use macroexp-progn. + * emacs-lisp/pcase.el: Use macroexp-let*, macroexp-if, ... + (pcase--let*): Remove. + * emacs-lisp/bytecomp.el (byte-compile-const-symbol-p) + (byte-compile-constp): Remove. Use macroexp--const-symbol-p and + macroexp-const-p instead. + * emacs-lisp/byte-opt.el: Use macroexp-const-p and macroexp-progn. + + * emacs-lisp/cl-macs.el: Clean up the name space by using "cl--" + instead of "cl-" for internal definitions. Use macroexp-const-p. + (cl-old-bc-file-form): Remove var. + (cl-const-exprs-p): Remove fun. + (cl-labels, cl-macrolet): Use backquote. + (cl-lexical-let): Use cl-symbol-macrolet. Don't use cl-defun-expander. + (cl-defun-expander, cl-byte-compile-compiler-macro): Remove fun. + (cl-define-setf-expander): Rename from cl-define-setf-method. + * emacs-lisp/cl.el: Adjust alias for define-setf-method. + + * international/mule-cmds.el: Don't require CL. + (view-hello-file): Don't use `letf'. + 2012-06-07 Stefan Monnier * tmm.el (tmm-prompt): Use string-prefix-p. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 117e837f47f..25b4686f87d 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -184,6 +184,7 @@ (require 'bytecomp) (eval-when-compile (require 'cl)) +(require 'macroexp) (defun byte-compile-log-lap-1 (format &rest args) ;; Newer byte codes for stack-ref make the slot 0 non-nil again. @@ -434,11 +435,9 @@ clause)) (cdr form)))) ((eq fn 'progn) - ;; as an extra added bonus, this simplifies (progn ) --> + ;; As an extra added bonus, this simplifies (progn ) --> . (if (cdr (cdr form)) - (progn - (setq tmp (byte-optimize-body (cdr form) for-effect)) - (if (cdr tmp) (cons 'progn tmp) (car tmp))) + (macroexp-progn (byte-optimize-body (cdr form) for-effect)) (byte-optimize-form (nth 1 form) for-effect))) ((eq fn 'prog1) (if (cdr (cdr form)) @@ -577,10 +576,10 @@ (cons fn args))))))) (defun byte-optimize-all-constp (list) - "Non-nil if all elements of LIST satisfy `byte-compile-constp'." + "Non-nil if all elements of LIST satisfy `macroexp-const-p" (let ((constant t)) (while (and list constant) - (unless (byte-compile-constp (car list)) + (unless (macroexp-const-p (car list)) (setq constant nil)) (setq list (cdr list))) constant)) @@ -870,8 +869,8 @@ (defun byte-optimize-binary-predicate (form) - (if (byte-compile-constp (nth 1 form)) - (if (byte-compile-constp (nth 2 form)) + (if (macroexp-const-p (nth 1 form)) + (if (macroexp-const-p (nth 2 form)) (condition-case () (list 'quote (eval form)) (error form)) @@ -883,7 +882,7 @@ (let ((ok t) (rest (cdr form))) (while (and rest ok) - (setq ok (byte-compile-constp (car rest)) + (setq ok (macroexp-const-p (car rest)) rest (cdr rest))) (if ok (condition-case () @@ -949,7 +948,7 @@ (defun byte-optimize-quote (form) (if (or (consp (nth 1 form)) (and (symbolp (nth 1 form)) - (not (byte-compile-const-symbol-p form)))) + (not (macroexp--const-symbol-p form)))) form (nth 1 form))) @@ -1586,13 +1585,13 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (not (eq (car lap0) 'byte-constant))) nil (setq keep-going t) - (if (memq (car lap0) '(byte-constant byte-dup)) - (progn - (setq tmp (if (or (not tmp) - (byte-compile-const-symbol-p - (car (cdr lap0)))) - (cdr lap0) - (byte-compile-get-constant t))) + (if (memq (car lap0) '(byte-constant byte-dup)) + (progn + (setq tmp (if (or (not tmp) + (macroexp--const-symbol-p + (car (cdr lap0)))) + (cdr lap0) + (byte-compile-get-constant t))) (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" lap0 lap1 lap2 lap0 lap1 (cons (car lap0) tmp)) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c5f5faec765..25a901fd248 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1464,29 +1464,6 @@ extra args." nil) -(defsubst byte-compile-const-symbol-p (symbol &optional any-value) - "Non-nil if SYMBOL is constant. -If ANY-VALUE is nil, only return non-nil if the value of the symbol is the -symbol itself." - (or (memq symbol '(nil t)) - (keywordp symbol) - (if any-value - (or (memq symbol byte-compile-const-variables) - ;; FIXME: We should provide a less intrusive way to find out - ;; if a variable is "constant". - (and (boundp symbol) - (condition-case nil - (progn (set symbol (symbol-value symbol)) nil) - (setting-constant t))))))) - -(defmacro byte-compile-constp (form) - "Return non-nil if FORM is a constant." - `(cond ((consp ,form) (or (eq (car ,form) 'quote) - (and (eq (car ,form) 'function) - (symbolp (cadr ,form))))) - ((not (symbolp ,form))) - ((byte-compile-const-symbol-p ,form)))) - ;; Dynamically bound in byte-compile-from-buffer. ;; NB also used in cl.el and cl-macs.el. (defvar byte-compile--outbuffer) @@ -2204,7 +2181,7 @@ list that represents a doc string reference. (put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) (defun byte-compile-file-form-autoload (form) (and (let ((form form)) - (while (if (setq form (cdr form)) (byte-compile-constp (car form)))) + (while (if (setq form (cdr form)) (macroexp-const-p (car form)))) (null form)) ;Constants only (eval (nth 5 form)) ;Macro (eval form)) ;Define the autoload. @@ -2510,7 +2487,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (symbolp arg) (byte-compile-set-symbol-position arg)) (cond ((or (not (symbolp arg)) - (byte-compile-const-symbol-p arg t)) + (macroexp--const-symbol-p arg t)) (error "Invalid lambda variable %s" arg)) ((eq arg '&rest) (unless (cdr list) @@ -2779,7 +2756,7 @@ for symbols generated by the byte compiler itself." (if (if (eq (car (car rest)) 'byte-constant) (or (consp tmp) (and (symbolp tmp) - (not (byte-compile-const-symbol-p tmp))))) + (not (macroexp--const-symbol-p tmp))))) (if maycall (setq body (cons (list 'quote tmp) body))) (setq body (cons tmp body)))) @@ -2850,7 +2827,7 @@ for symbols generated by the byte compiler itself." (let ((byte-compile--for-effect for-effect)) (cond ((not (consp form)) - (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) + (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) (when (symbolp form) (byte-compile-set-symbol-position form)) (byte-compile-constant form)) @@ -2863,7 +2840,7 @@ for symbols generated by the byte compiler itself." ((symbolp (car form)) (let* ((fn (car form)) (handler (get fn 'byte-compile))) - (when (byte-compile-const-symbol-p fn) + (when (macroexp--const-symbol-p fn) (byte-compile-warn "`%s' called as a function" fn)) (and (byte-compile-warning-enabled-p 'interactive-only) (memq fn byte-compile-interactive-only-functions) @@ -2997,7 +2974,7 @@ That command is designed for interactive use only" fn)) "Do various error checks before a use of the variable VAR." (when (symbolp var) (byte-compile-set-symbol-position var)) - (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var)) + (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) (when (byte-compile-warning-enabled-p 'constants) (byte-compile-warn (if (eq access-type 'let-bind) "attempt to let-bind %s `%s`" @@ -3568,7 +3545,7 @@ discarding." (byte-compile-form (cons 'progn (nreverse setters)))) (let ((var (car form))) (and (or (not (symbolp var)) - (byte-compile-const-symbol-p var t)) + (macroexp--const-symbol-p var t)) (byte-compile-warning-enabled-p 'constants) (byte-compile-warn "variable assignment to %s `%s'" @@ -4117,8 +4094,8 @@ binding slots have been popped." (defun byte-compile-autoload (form) (byte-compile-set-symbol-position 'autoload) - (and (byte-compile-constp (nth 1 form)) - (byte-compile-constp (nth 5 form)) + (and (macroexp-const-p (nth 1 form)) + (macroexp-const-p (nth 5 form)) (eval (nth 5 form)) ; macro-p (not (fboundp (eval (nth 1 form)))) (byte-compile-warn diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index d521ea32117..0e2c97f9c44 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -281,7 +281,7 @@ This also does some trivial optimizations to make the form prettier. ;;;;;; cl-assert cl-check-type cl-typep cl-deftype cl-struct-setf-expander ;;;;;; cl-defstruct cl-define-modify-macro cl-callf2 cl-callf cl-letf* ;;;;;; cl-letf cl-rotatef cl-shiftf cl-remf cl-do-pop cl-psetf cl-setf -;;;;;; cl-get-setf-method cl-defsetf cl-define-setf-method cl-declare +;;;;;; 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 @@ -289,7 +289,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" -;;;;;; "f3973150add70d26cadb8530147dfc99") +;;;;;; "25086e27342ec0990f35f1748a5b7b4e") ;;; Generated autoloads from cl-macs.el (autoload 'cl-gensym "cl-macs" "\ @@ -611,7 +611,7 @@ See Info node `(cl)Declarations' for details. \(fn &rest SPECS)" nil t) -(autoload 'cl-define-setf-method "cl-macs" "\ +(autoload 'cl-define-setf-expander "cl-macs" "\ Define a `cl-setf' method. This method shows how to handle `cl-setf's to places of the form (NAME ARGS...). The argument forms ARGS are bound according to ARGLIST, as if NAME were @@ -624,7 +624,7 @@ form. See `cl-defsetf' for a simpler way to define most setf-methods. (autoload 'cl-defsetf "cl-macs" "\ Define a `cl-setf' method. -This macro is an easy-to-use substitute for `cl-define-setf-method' that works +This macro is an easy-to-use substitute for `cl-define-setf-expander' that works well for simple place forms. In the simple `cl-defsetf' form, `cl-setf's of the form (cl-setf (NAME ARGS...) VAL) are transformed to function or macro calls of the form (FUNC ARGS... VAL). Example: diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index cf5282fd8d6..acb60373b5a 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -44,6 +44,7 @@ ;;; Code: (require 'cl-lib) +(require 'macroexp) (defmacro cl-pop2 (place) (declare (debug edebug-sexps)) @@ -54,58 +55,57 @@ (defvar cl-optimize-speed) -;; This kludge allows macros which use cl-transform-function-property +;; This kludge allows macros which use cl--transform-function-property ;; to be called at compile-time. (eval-and-compile - (or (fboundp 'cl-transform-function-property) - (defun cl-transform-function-property (n p f) + (or (fboundp 'cl--transform-function-property) + (defun cl--transform-function-property (n p f) `(put ',n ',p #'(lambda . ,f))))) ;;; Initialization. -(defvar cl-old-bc-file-form nil) +;;; Some predicates for analyzing Lisp forms. +;; These are used by various +;; macro expanders to optimize the results in certain common cases. -;;; Some predicates for analyzing Lisp forms. 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 +(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 +(defconst cl--safe-funcs '(* / % length memq list vector vectorp < > <= >= = error)) -;;; Check if no side effects, and executes quickly. -(defun cl-simple-expr-p (x &optional size) +(defun cl--simple-expr-p (x &optional size) + "Check if no side effects, and executes quickly." (or size (setq size 10)) (if (and (consp x) (not (memq (car x) '(quote function cl-function)))) (and (symbolp (car x)) - (or (memq (car x) cl-simple-funcs) + (or (memq (car x) cl--simple-funcs) (get (car x) 'side-effect-free)) (progn (setq size (1- size)) (while (and (setq x (cdr x)) - (setq size (cl-simple-expr-p (car x) size)))) + (setq size (cl--simple-expr-p (car x) size)))) (and (null x) (>= size 0) size))) (and (> size 0) (1- size)))) -(defun cl-simple-exprs-p (xs) - (while (and xs (cl-simple-expr-p (car xs))) +(defun cl--simple-exprs-p (xs) + (while (and xs (cl--simple-expr-p (car xs))) (setq xs (cdr xs))) (not xs)) -;;; Check if no side effects. -(defun cl-safe-expr-p (x) +(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) + (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)))) + (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) +(defun cl--const-expr-p (x) (cond ((consp x) (or (eq (car x) 'quote) (and (memq (car x) '(function cl-function)) @@ -114,13 +114,8 @@ ((symbolp x) (and (memq x '(nil t)) t)) (t t))) -(defun cl-const-exprs-p (xs) - (while (and xs (cl-const-expr-p (car xs))) - (setq xs (cdr xs))) - (not xs)) - -(defun cl-const-expr-val (x) - (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x))) +(defun cl--const-expr-val (x) + (and (macroexp-const-p x) (if (consp x) (nth 1 x) x))) (defun cl-expr-access-order (x v) ;; This apparently tries to return nil iff the expression X evaluates @@ -129,15 +124,15 @@ ;; to). ;; FIXME: This is very naive, it doesn't even check to see if those ;; variables appear more than once. - (if (cl-const-expr-p x) v + (if (macroexp-const-p x) v (if (consp x) (progn (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v))) v) (if (eq x (car v)) (cdr v) '(t))))) -;;; Count number of times X refers to Y. Return nil for 0 times. -(defun cl-expr-contains (x y) +(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 @@ -146,19 +141,19 @@ ((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))) + (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)) +(defun cl--expr-contains-any (x y) + (while (and y (not (cl--expr-contains x (car y)))) (pop y)) y) -;;; Check whether X may depend on any of the symbols in Y. -(defun cl-expr-depends-p (x y) - (and (not (cl-const-expr-p x)) - (or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y)))) +(defun cl--expr-depends-p (x y) + "Check whether X may depend on any of the symbols in Y." + (and (not (macroexp-const-p x)) + (or (not (cl--safe-expr-p x)) (cl--expr-contains-any x y)))) ;;; Symbols. @@ -224,7 +219,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). def-body)) (doc-string 3) (indent 2)) - (let* ((res (cl-transform-lambda (cons args body) name)) + (let* ((res (cl--transform-lambda (cons args body) name)) (form `(defun ,name ,@(cdr res)))) (if (car res) `(progn ,(car res) ,form) form))) @@ -277,7 +272,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). (&define name cl-macro-list cl-declarations-or-string def-body)) (doc-string 3) (indent 2)) - (let* ((res (cl-transform-lambda (cons args body) name)) + (let* ((res (cl--transform-lambda (cons args body) name)) (form `(defmacro ,name ,@(cdr res)))) (if (car res) `(progn ,(car res) ,form) form))) @@ -302,13 +297,13 @@ Like normal `function', except that if argument is a lambda form, its argument list allows full Common Lisp conventions." (declare (debug (&or symbolp cl-lambda-expr))) (if (eq (car-safe func) 'lambda) - (let* ((res (cl-transform-lambda (cdr func) 'cl-none)) + (let* ((res (cl--transform-lambda (cdr func) 'cl-none)) (form `(function (lambda . ,(cdr res))))) (if (car res) `(progn ,(car res) ,form) form)) `(function ,func))) -(defun cl-transform-function-property (func prop form) - (let ((res (cl-transform-lambda form func))) +(defun cl--transform-function-property (func prop form) + (let ((res (cl--transform-lambda form func))) `(progn ,@(cdr (cdr (car res))) (put ',func ',prop #'(lambda . ,(cdr res)))))) @@ -356,7 +351,7 @@ It is a list of elements of the form either: )))) arglist))) -(defun cl-transform-lambda (form cl-bind-block) +(defun cl--transform-lambda (form cl-bind-block) (let* ((args (car form)) (body (cdr form)) (orig-args args) (cl-bind-defs nil) (cl-bind-enquote nil) (cl-bind-inits nil) (cl-bind-lets nil) (cl-bind-forms nil) @@ -385,8 +380,8 @@ It is a list of elements of the form either: (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))) + (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))) @@ -408,7 +403,7 @@ It is a list of elements of the form either: ,@(nreverse cl-bind-forms) ,@body))))))) -(defun cl-do-arglist (args expr &optional num) ; uses bind-* +(defun cl--do-arglist (args expr &optional num) ; uses bind-* (if (nlistp args) (if (or (memq args cl-lambda-list-keywords) (not (symbolp args))) (error "Invalid argument name: %s" args) @@ -441,7 +436,7 @@ It is a list of elements of the form either: (while (and args (not (memq (car args) cl-lambda-list-keywords))) (let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car) restarg))) - (cl-do-arglist + (cl--do-arglist (pop args) (if (or laterarg (= safety 0)) poparg `(if ,minarg ,poparg @@ -454,18 +449,18 @@ It is a list of elements of the form either: (while (and args (not (memq (car args) cl-lambda-list-keywords))) (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) - (if (cddr arg) (cl-do-arglist (nth 2 arg) `(and ,restarg t))) + (if (cddr arg) (cl--do-arglist (nth 2 arg) `(and ,restarg t))) (let ((def (if (cdr arg) (nth 1 arg) (or (car cl-bind-defs) (nth 1 (assq (car arg) cl-bind-defs))))) (poparg `(pop ,restarg))) (and def cl-bind-enquote (setq def `',def)) - (cl-do-arglist (car arg) + (cl--do-arglist (car arg) (if def `(if ,restarg ,poparg ,def) poparg)) (setq num (1+ num)))))) (if (eq (car args) '&rest) (let ((arg (cl-pop2 args))) - (if (consp arg) (cl-do-arglist arg restarg))) + (if (consp arg) (cl--do-arglist arg restarg))) (or (eq (car args) '&key) (= safety 0) exactarg (push `(if ,restarg (signal 'wrong-number-of-arguments @@ -488,18 +483,18 @@ It is a list of elements of the form either: (if (cddr arg) (let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--"))) (val `(car (cdr ,temp)))) - (cl-do-arglist temp look) - (cl-do-arglist varg + (cl--do-arglist temp look) + (cl--do-arglist varg `(if ,temp (prog1 ,val (setq ,temp t)) ,def))) - (cl-do-arglist + (cl--do-arglist varg `(car (cdr ,(if (null def) look `(or ,look - ,(if (eq (cl-const-expr-p def) t) - `'(nil ,(cl-const-expr-val def)) + ,(if (eq (cl--const-expr-p def) t) + `'(nil ,(cl--const-expr-val def)) `(list nil ,def)))))))) (push karg keys))))) (setq keys (nreverse keys)) @@ -523,13 +518,13 @@ It is a list of elements of the form either: (while (and args (not (memq (car args) cl-lambda-list-keywords))) (if (consp (car args)) (if (and cl-bind-enquote (cl-cadar args)) - (cl-do-arglist (caar args) + (cl--do-arglist (caar args) `',(cadr (pop args))) - (cl-do-arglist (caar args) (cadr (pop args)))) - (cl-do-arglist (pop args) nil)))) + (cl--do-arglist (caar args) (cadr (pop args)))) + (cl--do-arglist (pop args) nil)))) (if args (error "Malformed argument list %s" save-args))))) -(defun cl-arglist-args (args) +(defun cl--arglist-args (args) (if (nlistp args) (list args) (let ((res nil) (kind nil) arg) (while (consp args) @@ -538,7 +533,7 @@ It is a list of elements of the form either: (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)))))) + (setq res (nconc res (cl--arglist-args arg)))))) (nconc res (and args (list args)))))) ;;;###autoload @@ -547,7 +542,7 @@ It is a list of elements of the form either: (debug (&define cl-macro-list def-form cl-declarations def-body))) (let* ((cl-bind-lets nil) (cl-bind-forms nil) (cl-bind-inits nil) (cl-bind-defs nil) (cl-bind-block 'cl-none) (cl-bind-enquote nil)) - (cl-do-arglist (or args '(&aux)) expr) + (cl--do-arglist (or args '(&aux)) expr) (append '(progn) cl-bind-inits (list `(let* ,(nreverse cl-bind-lets) ,@(nreverse cl-bind-forms) ,@body))))) @@ -571,18 +566,18 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) (cl-not-toplevel t)) (if (or (memq 'load when) (memq :load-toplevel when)) - (if comp (cons 'progn (mapcar 'cl-compile-time-too body)) + (if comp (cons 'progn (mapcar 'cl--compile-time-too body)) `(if nil nil ,@body)) (progn (if comp (eval (cons 'progn body))) nil))) (and (or (memq 'eval when) (memq :execute when)) (cons 'progn body)))) -(defun cl-compile-time-too (form) +(defun cl--compile-time-too (form) (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler)) (setq form (macroexpand form (cons '(cl-eval-when) byte-compile-macro-environment)))) (cond ((eq (car-safe form) 'progn) - (cons 'progn (mapcar 'cl-compile-time-too (cdr form)))) + (cons 'progn (mapcar 'cl--compile-time-too (cdr form)))) ((eq (car-safe form) 'cl-eval-when) (let ((when (nth 1 form))) (if (or (memq 'eval when) (memq :execute when)) @@ -624,7 +619,7 @@ allowed only in the final clause, and matches if no other keys match. Key values are compared by `eql'. \n(fn EXPR (KEYLIST BODY...)...)" (declare (indent 1) (debug (form &rest (sexp body)))) - (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) + (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (head-list nil) (body (cons 'cond @@ -667,7 +662,7 @@ final clause, and matches if no other keys match. \n(fn EXPR (TYPE BODY...)...)" (declare (indent 1) (debug (form &rest ([&or cl-type-spec "otherwise"] body)))) - (let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) + (let* ((temp (if (cl--simple-expr-p expr 3) expr (make-symbol "--cl-var--"))) (type-list nil) (body (cons 'cond @@ -680,7 +675,7 @@ final clause, and matches if no other keys match. ,temp ',(reverse type-list))) (t (push (car c) type-list) - (cl-make-type-test temp (car c)))) + (cl--make-type-test temp (car c)))) (or (cdr c) '(nil))))) clauses)))) (if (eq temp expr) body @@ -708,7 +703,7 @@ dynamically scoped: Only references to it within BODY will work. These references may appear inside macro expansions, but not inside functions called from BODY." (declare (indent 1) (debug (symbolp body))) - (if (cl-safe-expr-p `(progn ,@body)) `(progn ,@body) + (if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body) `(cl-block-wrapper (catch ',(intern (format "--cl-block-%s--" name)) ,@body)))) @@ -734,16 +729,16 @@ 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-destr-temps) -(defvar cl-loop-finally) (defvar cl-loop-finish-flag) -(defvar cl-loop-first-flag) -(defvar cl-loop-initially) (defvar cl-loop-map-form) (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) +(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-destr-temps) +(defvar cl--loop-finally) (defvar cl--loop-finish-flag) +(defvar cl--loop-first-flag) +(defvar cl--loop-initially) (defvar cl--loop-map-form) (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) ;;;###autoload -(defmacro cl-loop (&rest cl-loop-args) +(defmacro cl-loop (&rest cl--loop-args) "The Common Lisp `cl-loop' macro. Valid clauses are: for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM, @@ -759,30 +754,30 @@ Valid clauses are: \(fn CLAUSE...)" (declare (debug (&rest &or symbolp form))) - (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list cl-loop-args)))))) - `(cl-block nil (while t ,@cl-loop-args)) - (let ((cl-loop-name nil) (cl-loop-bindings nil) - (cl-loop-body nil) (cl-loop-steps nil) - (cl-loop-result nil) (cl-loop-result-explicit nil) - (cl-loop-result-var nil) (cl-loop-finish-flag nil) - (cl-loop-accum-var nil) (cl-loop-accum-vars nil) - (cl-loop-initially nil) (cl-loop-finally nil) - (cl-loop-map-form nil) (cl-loop-first-flag nil) - (cl-loop-destr-temps nil) (cl-loop-symbol-macs nil)) - (setq cl-loop-args (append cl-loop-args '(cl-end-loop))) - (while (not (eq (car cl-loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) - (if cl-loop-finish-flag - (push `((,cl-loop-finish-flag t)) cl-loop-bindings)) - (if cl-loop-first-flag - (progn (push `((,cl-loop-first-flag t)) cl-loop-bindings) - (push `(setq ,cl-loop-first-flag nil) cl-loop-steps))) - (let* ((epilogue (nconc (nreverse cl-loop-finally) - (list (or cl-loop-result-explicit cl-loop-result)))) - (ands (cl-loop-build-ands (nreverse cl-loop-body))) - (while-body (nconc (cadr ands) (nreverse cl-loop-steps))) + (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list cl--loop-args)))))) + `(cl-block nil (while t ,@cl--loop-args)) + (let ((cl--loop-name nil) (cl--loop-bindings nil) + (cl--loop-body nil) (cl--loop-steps nil) + (cl--loop-result nil) (cl--loop-result-explicit nil) + (cl--loop-result-var nil) (cl--loop-finish-flag nil) + (cl--loop-accum-var nil) (cl--loop-accum-vars nil) + (cl--loop-initially nil) (cl--loop-finally nil) + (cl--loop-map-form nil) (cl--loop-first-flag nil) + (cl--loop-destr-temps nil) (cl--loop-symbol-macs nil)) + (setq cl--loop-args (append cl--loop-args '(cl-end-loop))) + (while (not (eq (car cl--loop-args) 'cl-end-loop)) (cl-parse-loop-clause)) + (if cl--loop-finish-flag + (push `((,cl--loop-finish-flag t)) cl--loop-bindings)) + (if cl--loop-first-flag + (progn (push `((,cl--loop-first-flag t)) cl--loop-bindings) + (push `(setq ,cl--loop-first-flag nil) cl--loop-steps))) + (let* ((epilogue (nconc (nreverse cl--loop-finally) + (list (or cl--loop-result-explicit cl--loop-result)))) + (ands (cl--loop-build-ands (nreverse cl--loop-body))) + (while-body (nconc (cadr ands) (nreverse cl--loop-steps))) (body (append - (nreverse cl-loop-initially) - (list (if cl-loop-map-form + (nreverse cl--loop-initially) + (list (if cl--loop-map-form `(cl-block --cl-finish-- ,(cl-subst (if (eq (car ands) t) while-body @@ -790,25 +785,25 @@ Valid clauses are: (cl-return-from --cl-finish-- nil)) while-body)) - '--cl-map cl-loop-map-form)) + '--cl-map cl--loop-map-form)) `(while ,(car ands) ,@while-body))) - (if cl-loop-finish-flag - (if (equal epilogue '(nil)) (list cl-loop-result-var) - `((if ,cl-loop-finish-flag - (progn ,@epilogue) ,cl-loop-result-var))) + (if cl--loop-finish-flag + (if (equal epilogue '(nil)) (list cl--loop-result-var) + `((if ,cl--loop-finish-flag + (progn ,@epilogue) ,cl--loop-result-var))) epilogue)))) - (if cl-loop-result-var (push (list cl-loop-result-var) cl-loop-bindings)) - (while cl-loop-bindings - (if (cdar cl-loop-bindings) - (setq body (list (cl-loop-let (pop cl-loop-bindings) body t))) + (if cl--loop-result-var (push (list cl--loop-result-var) cl--loop-bindings)) + (while cl--loop-bindings + (if (cdar cl--loop-bindings) + (setq body (list (cl--loop-let (pop cl--loop-bindings) body t))) (let ((lets nil)) - (while (and cl-loop-bindings - (not (cdar cl-loop-bindings))) - (push (car (pop cl-loop-bindings)) lets)) - (setq body (list (cl-loop-let lets body nil)))))) - (if cl-loop-symbol-macs - (setq body (list `(cl-symbol-macrolet ,cl-loop-symbol-macs ,@body)))) - `(cl-block ,cl-loop-name ,@body))))) + (while (and cl--loop-bindings + (not (cdar cl--loop-bindings))) + (push (car (pop cl--loop-bindings)) lets)) + (setq body (list (cl--loop-let lets body nil)))))) + (if cl--loop-symbol-macs + (setq body (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body)))) + `(cl-block ,cl--loop-name ,@body))))) ;; Below is a complete spec for cl-loop, in several parts that correspond ;; to the syntax given in CLtL2. The specs do more than specify where @@ -963,33 +958,33 @@ Valid clauses are: (defun cl-parse-loop-clause () ; uses loop-* - (let ((word (pop cl-loop-args)) + (let ((word (pop cl--loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) (key-types '(key-code key-codes key-seq key-seqs key-binding key-bindings))) (cond - ((null cl-loop-args) + ((null cl--loop-args) (error "Malformed `cl-loop' macro")) ((eq word 'named) - (setq cl-loop-name (pop cl-loop-args))) + (setq cl--loop-name (pop cl--loop-args))) ((eq word 'initially) - (if (memq (car cl-loop-args) '(do doing)) (pop cl-loop-args)) - (or (consp (car cl-loop-args)) (error "Syntax error on `initially' clause")) - (while (consp (car cl-loop-args)) - (push (pop cl-loop-args) cl-loop-initially))) + (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) + (or (consp (car cl--loop-args)) (error "Syntax error on `initially' clause")) + (while (consp (car cl--loop-args)) + (push (pop cl--loop-args) cl--loop-initially))) ((eq word 'finally) - (if (eq (car cl-loop-args) 'return) - (setq cl-loop-result-explicit (or (cl-pop2 cl-loop-args) '(quote nil))) - (if (memq (car cl-loop-args) '(do doing)) (pop cl-loop-args)) - (or (consp (car cl-loop-args)) (error "Syntax error on `finally' clause")) - (if (and (eq (caar cl-loop-args) 'return) (null cl-loop-name)) - (setq cl-loop-result-explicit (or (nth 1 (pop cl-loop-args)) '(quote nil))) - (while (consp (car cl-loop-args)) - (push (pop cl-loop-args) cl-loop-finally))))) + (if (eq (car cl--loop-args) 'return) + (setq cl--loop-result-explicit (or (cl-pop2 cl--loop-args) '(quote nil))) + (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args)) + (or (consp (car cl--loop-args)) (error "Syntax error on `finally' clause")) + (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name)) + (setq cl--loop-result-explicit (or (nth 1 (pop cl--loop-args)) '(quote nil))) + (while (consp (car cl--loop-args)) + (push (pop cl--loop-args) cl--loop-finally))))) ((memq word '(for as)) (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil) @@ -997,33 +992,33 @@ Valid clauses are: (while ;; 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 (or (pop cl-loop-args) (cl-gensym "--cl-var--")))) - (setq word (pop cl-loop-args)) - (if (eq word 'being) (setq word (pop cl-loop-args))) - (if (memq word '(the each)) (setq word (pop cl-loop-args))) + ;; these vars get added to the macro-environment. + (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--")))) + (setq word (pop cl--loop-args)) + (if (eq word 'being) (setq word (pop cl--loop-args))) + (if (memq word '(the each)) (setq word (pop cl--loop-args))) (if (memq word '(buffer buffers)) - (setq word 'in cl-loop-args (cons '(buffer-list) cl-loop-args))) + (setq word 'in cl--loop-args (cons '(buffer-list) cl--loop-args))) (cond ((memq word '(from downfrom upfrom to downto upto above below by)) - (push word cl-loop-args) - (if (memq (car cl-loop-args) '(downto above)) + (push word cl--loop-args) + (if (memq (car cl--loop-args) '(downto above)) (error "Must specify `from' value for downward cl-loop")) - (let* ((down (or (eq (car cl-loop-args) 'downfrom) - (memq (cl-caddr cl-loop-args) '(downto above)))) - (excl (or (memq (car cl-loop-args) '(above below)) - (memq (cl-caddr cl-loop-args) '(above below)))) - (start (and (memq (car cl-loop-args) '(from upfrom downfrom)) - (cl-pop2 cl-loop-args))) - (end (and (memq (car cl-loop-args) + (let* ((down (or (eq (car cl--loop-args) 'downfrom) + (memq (cl-caddr cl--loop-args) '(downto above)))) + (excl (or (memq (car cl--loop-args) '(above below)) + (memq (cl-caddr cl--loop-args) '(above below)))) + (start (and (memq (car cl--loop-args) '(from upfrom downfrom)) + (cl-pop2 cl--loop-args))) + (end (and (memq (car cl--loop-args) '(to upto downto above below)) - (cl-pop2 cl-loop-args))) - (step (and (eq (car cl-loop-args) 'by) (cl-pop2 cl-loop-args))) - (end-var (and (not (cl-const-expr-p end)) + (cl-pop2 cl--loop-args))) + (step (and (eq (car cl--loop-args) 'by) (cl-pop2 cl--loop-args))) + (end-var (and (not (macroexp-const-p end)) (make-symbol "--cl-var--"))) - (step-var (and (not (cl-const-expr-p step)) + (step-var (and (not (macroexp-const-p step)) (make-symbol "--cl-var--")))) (and step (numberp step) (<= step 0) (error "Loop `by' value is not positive: %s" step)) @@ -1034,7 +1029,7 @@ Valid clauses are: (if end (push (list (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) cl-loop-body)) + var (or end-var end)) cl--loop-body)) (push (list var (list (if down '- '+) var (or step-var step 1))) loop-for-steps))) @@ -1043,18 +1038,18 @@ Valid clauses are: (let* ((on (eq word 'on)) (temp (if (and on (symbolp var)) var (make-symbol "--cl-var--")))) - (push (list temp (pop cl-loop-args)) loop-for-bindings) - (push `(consp ,temp) cl-loop-body) + (push (list temp (pop cl--loop-args)) loop-for-bindings) + (push `(consp ,temp) cl--loop-body) (if (eq word 'in-ref) - (push (list var `(car ,temp)) cl-loop-symbol-macs) + (push (list var `(car ,temp)) cl--loop-symbol-macs) (or (eq temp var) (progn (push (list var nil) loop-for-bindings) (push (list var (if on temp `(car ,temp))) loop-for-sets)))) (push (list temp - (if (eq (car cl-loop-args) 'by) - (let ((step (cl-pop2 cl-loop-args))) + (if (eq (car cl--loop-args) 'by) + (let ((step (cl-pop2 cl--loop-args))) (if (and (memq (car-safe step) '(quote function cl-function)) @@ -1065,22 +1060,22 @@ Valid clauses are: loop-for-steps))) ((eq word '=) - (let* ((start (pop cl-loop-args)) - (then (if (eq (car cl-loop-args) 'then) (cl-pop2 cl-loop-args) start))) + (let* ((start (pop cl--loop-args)) + (then (if (eq (car cl--loop-args) 'then) (cl-pop2 cl--loop-args) start))) (push (list var nil) loop-for-bindings) - (if (or ands (eq (car cl-loop-args) 'and)) + (if (or ands (eq (car cl--loop-args) 'and)) (progn (push `(,var - (if ,(or cl-loop-first-flag - (setq cl-loop-first-flag + (if ,(or cl--loop-first-flag + (setq cl--loop-first-flag (make-symbol "--cl-var--"))) ,start ,var)) loop-for-sets) (push (list var then) loop-for-steps)) (push (list var (if (eq start then) start - `(if ,(or cl-loop-first-flag - (setq cl-loop-first-flag + `(if ,(or cl--loop-first-flag + (setq cl--loop-first-flag (make-symbol "--cl-var--"))) ,start ,then))) loop-for-sets)))) @@ -1088,27 +1083,27 @@ Valid clauses are: ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) (temp-idx (make-symbol "--cl-idx--"))) - (push (list temp-vec (pop cl-loop-args)) loop-for-bindings) + (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) (push `(< (setq ,temp-idx (1+ ,temp-idx)) - (length ,temp-vec)) cl-loop-body) + (length ,temp-vec)) cl--loop-body) (if (eq word 'across-ref) (push (list var `(aref ,temp-vec ,temp-idx)) - cl-loop-symbol-macs) + cl--loop-symbol-macs) (push (list var nil) loop-for-bindings) (push (list var `(aref ,temp-vec ,temp-idx)) loop-for-sets)))) ((memq word '(element elements)) - (let ((ref (or (memq (car cl-loop-args) '(in-ref of-ref)) - (and (not (memq (car cl-loop-args) '(in of))) + (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref)) + (and (not (memq (car cl--loop-args) '(in of))) (error "Expected `of'")))) - (seq (cl-pop2 cl-loop-args)) + (seq (cl-pop2 cl--loop-args)) (temp-seq (make-symbol "--cl-seq--")) - (temp-idx (if (eq (car cl-loop-args) 'using) - (if (and (= (length (cadr cl-loop-args)) 2) - (eq (cl-caadr cl-loop-args) 'index)) - (cadr (cl-pop2 cl-loop-args)) + (temp-idx (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (eq (cl-caadr cl--loop-args) 'index)) + (cadr (cl-pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-idx--")))) (push (list temp-seq seq) loop-for-bindings) @@ -1118,13 +1113,13 @@ Valid clauses are: (push (list temp-len `(length ,temp-seq)) loop-for-bindings) (push (list var `(elt ,temp-seq temp-idx)) - cl-loop-symbol-macs) - (push `(< ,temp-idx ,temp-len) cl-loop-body)) + cl--loop-symbol-macs) + (push `(< ,temp-idx ,temp-len) cl--loop-body)) (push (list var nil) loop-for-bindings) (push `(and ,temp-seq (or (consp ,temp-seq) (< ,temp-idx (length ,temp-seq)))) - cl-loop-body) + cl--loop-body) (push (list var `(if (consp ,temp-seq) (pop ,temp-seq) (aref ,temp-seq ,temp-idx))) @@ -1133,33 +1128,33 @@ Valid clauses are: loop-for-steps))) ((memq word hash-types) - (or (memq (car cl-loop-args) '(in of)) (error "Expected `of'")) - (let* ((table (cl-pop2 cl-loop-args)) - (other (if (eq (car cl-loop-args) 'using) - (if (and (= (length (cadr cl-loop-args)) 2) - (memq (cl-caadr cl-loop-args) hash-types) - (not (eq (cl-caadr cl-loop-args) word))) - (cadr (cl-pop2 cl-loop-args)) + (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) + (let* ((table (cl-pop2 cl--loop-args)) + (other (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (cl-caadr cl--loop-args) hash-types) + (not (eq (cl-caadr cl--loop-args) word))) + (cadr (cl-pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(hash-value hash-values)) (setq var (prog1 other (setq other var)))) - (setq cl-loop-map-form + (setq cl--loop-map-form `(maphash (lambda (,var ,other) . --cl-map) ,table)))) ((memq word '(symbol present-symbol external-symbol symbols present-symbols external-symbols)) - (let ((ob (and (memq (car cl-loop-args) '(in of)) (cl-pop2 cl-loop-args)))) - (setq cl-loop-map-form + (let ((ob (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args)))) + (setq cl--loop-map-form `(mapatoms (lambda (,var) . --cl-map) ,ob)))) ((memq word '(overlay overlays extent extents)) (let ((buf nil) (from nil) (to nil)) - (while (memq (car cl-loop-args) '(in of from to)) - (cond ((eq (car cl-loop-args) 'from) (setq from (cl-pop2 cl-loop-args))) - ((eq (car cl-loop-args) 'to) (setq to (cl-pop2 cl-loop-args))) - (t (setq buf (cl-pop2 cl-loop-args))))) - (setq cl-loop-map-form + (while (memq (car cl--loop-args) '(in of from to)) + (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) + (t (setq buf (cl-pop2 cl--loop-args))))) + (setq cl--loop-map-form `(cl-map-extents (lambda (,var ,(make-symbol "--cl-var--")) (progn . --cl-map) nil) @@ -1169,33 +1164,33 @@ Valid clauses are: (let ((buf nil) (prop nil) (from nil) (to nil) (var1 (make-symbol "--cl-var1--")) (var2 (make-symbol "--cl-var2--"))) - (while (memq (car cl-loop-args) '(in of property from to)) - (cond ((eq (car cl-loop-args) 'from) (setq from (cl-pop2 cl-loop-args))) - ((eq (car cl-loop-args) 'to) (setq to (cl-pop2 cl-loop-args))) - ((eq (car cl-loop-args) 'property) - (setq prop (cl-pop2 cl-loop-args))) - (t (setq buf (cl-pop2 cl-loop-args))))) + (while (memq (car cl--loop-args) '(in of property from to)) + (cond ((eq (car cl--loop-args) 'from) (setq from (cl-pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'to) (setq to (cl-pop2 cl--loop-args))) + ((eq (car cl--loop-args) 'property) + (setq prop (cl-pop2 cl--loop-args))) + (t (setq buf (cl-pop2 cl--loop-args))))) (if (and (consp var) (symbolp (car var)) (symbolp (cdr var))) (setq var1 (car var) var2 (cdr var)) (push (list var `(cons ,var1 ,var2)) loop-for-sets)) - (setq cl-loop-map-form + (setq cl--loop-map-form `(cl-map-intervals (lambda (,var1 ,var2) . --cl-map) ,buf ,prop ,from ,to)))) ((memq word key-types) - (or (memq (car cl-loop-args) '(in of)) (error "Expected `of'")) - (let ((cl-map (cl-pop2 cl-loop-args)) - (other (if (eq (car cl-loop-args) 'using) - (if (and (= (length (cadr cl-loop-args)) 2) - (memq (cl-caadr cl-loop-args) key-types) - (not (eq (cl-caadr cl-loop-args) word))) - (cadr (cl-pop2 cl-loop-args)) + (or (memq (car cl--loop-args) '(in of)) (error "Expected `of'")) + (let ((cl-map (cl-pop2 cl--loop-args)) + (other (if (eq (car cl--loop-args) 'using) + (if (and (= (length (cadr cl--loop-args)) 2) + (memq (cl-caadr cl--loop-args) key-types) + (not (eq (cl-caadr cl--loop-args) word))) + (cadr (cl-pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) (if (memq word '(key-binding key-bindings)) (setq var (prog1 other (setq other var)))) - (setq cl-loop-map-form + (setq cl--loop-map-form `(,(if (memq word '(key-seq key-seqs)) 'cl-map-keymap-recursively 'map-keymap) (lambda (,var ,other) . --cl-map) ,cl-map)))) @@ -1207,12 +1202,12 @@ Valid clauses are: (push (list temp nil) loop-for-bindings) (push `(prog1 (not (eq ,var ,temp)) (or ,temp (setq ,temp ,var))) - cl-loop-body) + cl--loop-body) (push (list var `(next-frame ,var)) loop-for-steps))) ((memq word '(window windows)) - (let ((scr (and (memq (car cl-loop-args) '(in of)) (cl-pop2 cl-loop-args))) + (let ((scr (and (memq (car cl--loop-args) '(in of)) (cl-pop2 cl--loop-args))) (temp (make-symbol "--cl-var--")) (minip (make-symbol "--cl-minip--"))) (push (list var (if scr @@ -1229,52 +1224,52 @@ Valid clauses are: (push (list temp nil) loop-for-bindings) (push `(prog1 (not (eq ,var ,temp)) (or ,temp (setq ,temp ,var))) - cl-loop-body) + cl--loop-body) (push (list var `(next-window ,var ,minip)) loop-for-steps))) (t (let ((handler (and (symbolp word) - (get word 'cl-loop-for-handler)))) + (get word 'cl--loop-for-handler)))) (if handler (funcall handler var) (error "Expected a `for' preposition, found %s" word))))) - (eq (car cl-loop-args) 'and)) + (eq (car cl--loop-args) 'and)) (setq ands t) - (pop cl-loop-args)) + (pop cl--loop-args)) (if (and ands loop-for-bindings) - (push (nreverse loop-for-bindings) cl-loop-bindings) - (setq cl-loop-bindings (nconc (mapcar 'list loop-for-bindings) - cl-loop-bindings))) + (push (nreverse loop-for-bindings) cl--loop-bindings) + (setq cl--loop-bindings (nconc (mapcar 'list loop-for-bindings) + cl--loop-bindings))) (if loop-for-sets (push `(progn - ,(cl-loop-let (nreverse loop-for-sets) 'setq ands) - t) cl-loop-body)) + ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) + t) cl--loop-body)) (if loop-for-steps (push (cons (if ands 'cl-psetq 'setq) (apply 'append (nreverse loop-for-steps))) - cl-loop-steps)))) + cl--loop-steps)))) ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) - (push (list (list temp (pop cl-loop-args))) cl-loop-bindings) - (push `(>= (setq ,temp (1- ,temp)) 0) cl-loop-body))) + (push (list (list temp (pop cl--loop-args))) cl--loop-bindings) + (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body))) ((memq word '(collect collecting)) - (let ((what (pop cl-loop-args)) - (var (cl-loop-handle-accum nil 'nreverse))) - (if (eq var cl-loop-accum-var) - (push `(progn (push ,what ,var) t) cl-loop-body) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum nil 'nreverse))) + (if (eq var cl--loop-accum-var) + (push `(progn (push ,what ,var) t) cl--loop-body) (push `(progn (setq ,var (nconc ,var (list ,what))) - t) cl-loop-body)))) + t) cl--loop-body)))) ((memq word '(nconc nconcing append appending)) - (let ((what (pop cl-loop-args)) - (var (cl-loop-handle-accum nil 'nreverse))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum nil 'nreverse))) (push `(progn (setq ,var - ,(if (eq var cl-loop-accum-var) + ,(if (eq var cl--loop-accum-var) `(nconc (,(if (memq word '(nconc nconcing)) #'nreverse #'reverse) @@ -1282,113 +1277,113 @@ Valid clauses are: ,var) `(,(if (memq word '(nconc nconcing)) #'nconc #'append) - ,var ,what))) t) cl-loop-body))) + ,var ,what))) t) cl--loop-body))) ((memq word '(concat concating)) - (let ((what (pop cl-loop-args)) - (var (cl-loop-handle-accum ""))) - (push `(progn (cl-callf concat ,var ,what) t) cl-loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum ""))) + (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body))) ((memq word '(vconcat vconcating)) - (let ((what (pop cl-loop-args)) - (var (cl-loop-handle-accum []))) - (push `(progn (cl-callf vconcat ,var ,what) t) cl-loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum []))) + (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body))) ((memq word '(sum summing)) - (let ((what (pop cl-loop-args)) - (var (cl-loop-handle-accum 0))) - (push `(progn (cl-incf ,var ,what) t) cl-loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum 0))) + (push `(progn (cl-incf ,var ,what) t) cl--loop-body))) ((memq word '(count counting)) - (let ((what (pop cl-loop-args)) - (var (cl-loop-handle-accum 0))) - (push `(progn (if ,what (cl-incf ,var)) t) cl-loop-body))) + (let ((what (pop cl--loop-args)) + (var (cl--loop-handle-accum 0))) + (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body))) ((memq word '(minimize minimizing maximize maximizing)) - (let* ((what (pop cl-loop-args)) - (temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--"))) - (var (cl-loop-handle-accum nil)) + (let* ((what (pop cl--loop-args)) + (temp (if (cl--simple-expr-p what) what (make-symbol "--cl-var--"))) + (var (cl--loop-handle-accum nil)) (func (intern (substring (symbol-name word) 0 3))) (set `(setq ,var (if ,var (,func ,var ,temp) ,temp)))) (push `(progn ,(if (eq temp what) set `(let ((,temp ,what)) ,set)) - t) cl-loop-body))) + t) cl--loop-body))) ((eq word 'with) (let ((bindings nil)) - (while (progn (push (list (pop cl-loop-args) - (and (eq (car cl-loop-args) '=) (cl-pop2 cl-loop-args))) + (while (progn (push (list (pop cl--loop-args) + (and (eq (car cl--loop-args) '=) (cl-pop2 cl--loop-args))) bindings) - (eq (car cl-loop-args) 'and)) - (pop cl-loop-args)) - (push (nreverse bindings) cl-loop-bindings))) + (eq (car cl--loop-args) 'and)) + (pop cl--loop-args)) + (push (nreverse bindings) cl--loop-bindings))) ((eq word 'while) - (push (pop cl-loop-args) cl-loop-body)) + (push (pop cl--loop-args) cl--loop-body)) ((eq word 'until) - (push `(not ,(pop cl-loop-args)) cl-loop-body)) + (push `(not ,(pop cl--loop-args)) cl--loop-body)) ((eq word 'always) - (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-flag--"))) - (push `(setq ,cl-loop-finish-flag ,(pop cl-loop-args)) cl-loop-body) - (setq cl-loop-result t)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body) + (setq cl--loop-result t)) ((eq word 'never) - (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-flag--"))) - (push `(setq ,cl-loop-finish-flag (not ,(pop cl-loop-args))) - cl-loop-body) - (setq cl-loop-result t)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args))) + cl--loop-body) + (setq cl--loop-result t)) ((eq word 'thereis) - (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-flag--"))) - (or cl-loop-result-var (setq cl-loop-result-var (make-symbol "--cl-var--"))) - (push `(setq ,cl-loop-finish-flag - (not (setq ,cl-loop-result-var ,(pop cl-loop-args)))) - cl-loop-body)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-flag--"))) + (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl--loop-finish-flag + (not (setq ,cl--loop-result-var ,(pop cl--loop-args)))) + cl--loop-body)) ((memq word '(if when unless)) - (let* ((cond (pop cl-loop-args)) - (then (let ((cl-loop-body nil)) + (let* ((cond (pop cl--loop-args)) + (then (let ((cl--loop-body nil)) (cl-parse-loop-clause) - (cl-loop-build-ands (nreverse cl-loop-body)))) - (else (let ((cl-loop-body nil)) - (if (eq (car cl-loop-args) 'else) - (progn (pop cl-loop-args) (cl-parse-loop-clause))) - (cl-loop-build-ands (nreverse cl-loop-body)))) + (cl--loop-build-ands (nreverse cl--loop-body)))) + (else (let ((cl--loop-body nil)) + (if (eq (car cl--loop-args) 'else) + (progn (pop cl--loop-args) (cl-parse-loop-clause))) + (cl--loop-build-ands (nreverse cl--loop-body)))) (simple (and (eq (car then) t) (eq (car else) t)))) - (if (eq (car cl-loop-args) 'end) (pop cl-loop-args)) + (if (eq (car cl--loop-args) 'end) (pop cl--loop-args)) (if (eq word 'unless) (setq then (prog1 else (setq else then)))) (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then)) (if simple (nth 1 else) (list (nth 2 else)))))) - (if (cl-expr-contains form 'it) + (if (cl--expr-contains form 'it) (let ((temp (make-symbol "--cl-var--"))) - (push (list temp) cl-loop-bindings) + (push (list temp) cl--loop-bindings) (setq form `(if (setq ,temp ,cond) ,@(cl-subst temp 'it form)))) (setq form `(if ,cond ,@form))) - (push (if simple `(progn ,form t) form) cl-loop-body)))) + (push (if simple `(progn ,form t) form) cl--loop-body)))) ((memq word '(do doing)) (let ((body nil)) - (or (consp (car cl-loop-args)) (error "Syntax error on `do' clause")) - (while (consp (car cl-loop-args)) (push (pop cl-loop-args) body)) - (push (cons 'progn (nreverse (cons t body))) cl-loop-body))) + (or (consp (car cl--loop-args)) (error "Syntax error on `do' clause")) + (while (consp (car cl--loop-args)) (push (pop cl--loop-args) body)) + (push (cons 'progn (nreverse (cons t body))) cl--loop-body))) ((eq word 'return) - (or cl-loop-finish-flag (setq cl-loop-finish-flag (make-symbol "--cl-var--"))) - (or cl-loop-result-var (setq cl-loop-result-var (make-symbol "--cl-var--"))) - (push `(setq ,cl-loop-result-var ,(pop cl-loop-args) - ,cl-loop-finish-flag nil) cl-loop-body)) + (or cl--loop-finish-flag (setq cl--loop-finish-flag (make-symbol "--cl-var--"))) + (or cl--loop-result-var (setq cl--loop-result-var (make-symbol "--cl-var--"))) + (push `(setq ,cl--loop-result-var ,(pop cl--loop-args) + ,cl--loop-finish-flag nil) cl--loop-body)) (t - (let ((handler (and (symbolp word) (get word 'cl-loop-handler)))) + (let ((handler (and (symbolp word) (get word 'cl--loop-handler)))) (or handler (error "Expected a cl-loop keyword, found %s" word)) (funcall handler)))) - (if (eq (car cl-loop-args) 'and) - (progn (pop cl-loop-args) (cl-parse-loop-clause))))) + (if (eq (car cl--loop-args) 'and) + (progn (pop cl--loop-args) (cl-parse-loop-clause))))) -(defun cl-loop-let (specs body par) ; uses loop-* +(defun cl--loop-let (specs body par) ; uses loop-* (let ((p specs) (temps nil) (new nil)) (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p)))) (setq p (cdr p))) @@ -1396,7 +1391,7 @@ Valid clauses are: (progn (setq par nil p specs) (while p - (or (cl-const-expr-p (cl-cadar p)) + (or (macroexp-const-p (cl-cadar p)) (let ((temp (make-symbol "--cl-var--"))) (push (list temp (cl-cadar p)) temps) (setcar (cdar p) temp))) @@ -1405,10 +1400,10 @@ Valid clauses are: (if (and (consp (car specs)) (listp (caar specs))) (let* ((spec (caar specs)) (nspecs nil) (expr (cadr (pop specs))) - (temp (cdr (or (assq spec cl-loop-destr-temps) + (temp (cdr (or (assq spec cl--loop-destr-temps) (car (push (cons spec (or (last spec 0) (make-symbol "--cl-var--"))) - cl-loop-destr-temps)))))) + cl--loop-destr-temps)))))) (push (list temp expr) new) (while (consp spec) (push (list (pop spec) @@ -1422,22 +1417,22 @@ Valid clauses are: `(,(if par 'let 'let*) ,(nconc (nreverse temps) (nreverse new)) ,@body)))) -(defun cl-loop-handle-accum (def &optional func) ; uses loop-* - (if (eq (car cl-loop-args) 'into) - (let ((var (cl-pop2 cl-loop-args))) - (or (memq var cl-loop-accum-vars) - (progn (push (list (list var def)) cl-loop-bindings) - (push var cl-loop-accum-vars))) +(defun cl--loop-handle-accum (def &optional func) ; uses loop-* + (if (eq (car cl--loop-args) 'into) + (let ((var (cl-pop2 cl--loop-args))) + (or (memq var cl--loop-accum-vars) + (progn (push (list (list var def)) cl--loop-bindings) + (push var cl--loop-accum-vars))) var) - (or cl-loop-accum-var + (or cl--loop-accum-var (progn - (push (list (list (setq cl-loop-accum-var (make-symbol "--cl-var--")) def)) - cl-loop-bindings) - (setq cl-loop-result (if func (list func cl-loop-accum-var) - cl-loop-accum-var)) - cl-loop-accum-var)))) + (push (list (list (setq cl--loop-accum-var (make-symbol "--cl-var--")) def)) + cl--loop-bindings) + (setq cl--loop-result (if func (list func cl--loop-accum-var) + cl--loop-accum-var)) + cl--loop-accum-var)))) -(defun cl-loop-build-ands (clauses) +(defun cl--loop-build-ands (clauses) (let ((ands nil) (body nil)) (while clauses @@ -1671,9 +1666,10 @@ Unlike `cl-flet', this macro is fully compliant with the Common Lisp standard. (push var vars) (push `(cl-function (lambda . ,(cdar bindings))) sets) (push var sets) - (push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args) - `(cl-list* 'funcall ',var - cl-labels-args)) + (push (cons (car (pop bindings)) + `(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))) @@ -1695,10 +1691,10 @@ This is like `cl-flet', but for macros instead of functions. `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) (if (null bindings) (cons 'progn body) (let* ((name (caar bindings)) - (res (cl-transform-lambda (cdar bindings) name))) + (res (cl--transform-lambda (cdar bindings) name))) (eval (car res)) (cl-macroexpand-all (cons 'progn body) - (cons (cl-list* name 'lambda (cdr res)) + (cons (cons name `(lambda ,@(cdr res))) cl-macro-environment)))))) ;;;###autoload @@ -1737,13 +1733,12 @@ lexical closures as in Common Lisp. bindings)) (ebody (cl-macroexpand-all - (cons 'progn body) - (nconc (mapcar (function (lambda (x) - (list (symbol-name (car x)) - `(symbol-value ,(cl-caddr x)) - t))) vars) - (list '(defun . cl-defun-expander)) - cl-macro-environment)))) + `(cl-symbol-macrolet + ,(mapcar (lambda (x) + `(,(car x) (symbol-value ,(cl-caddr x)))) + vars) + ,@body) + cl-macro-environment))) (if (not (get (car (last cl-closure-vars)) 'used)) ;; Turn (let ((foo (cl-gensym))) ;; (set foo ) ...(symbol-value foo)...) @@ -1784,12 +1779,6 @@ Common Lisp. (setq body (list `(cl-lexical-let (,(pop bindings)) ,@body)))) (car body))) -(defun cl-defun-expander (func &rest rest) - `(progn - (defalias ',func #'(lambda ,@rest)) - ',func)) - - ;;; Multiple values. ;;;###autoload @@ -1912,7 +1901,7 @@ See Info node `(cl)Declarations' for details." ;;; Generalized variables. ;;;###autoload -(defmacro cl-define-setf-method (func args &rest body) +(defmacro cl-define-setf-expander (func args &rest body) "Define a `cl-setf' method. This method shows how to handle `cl-setf's to places of the form (NAME ARGS...). The argument forms ARGS are bound according to ARGLIST, as if NAME were @@ -1927,14 +1916,13 @@ form. See `cl-defsetf' for a simpler way to define most setf-methods. `(cl-eval-when (compile load eval) ,@(if (stringp (car body)) (list `(put ',func 'setf-documentation ,(pop body)))) - ,(cl-transform-function-property + ,(cl--transform-function-property func 'setf-method (cons args body)))) -(defalias 'cl-define-setf-expander 'cl-define-setf-method) ;;;###autoload (defmacro cl-defsetf (func arg1 &rest args) "Define a `cl-setf' method. -This macro is an easy-to-use substitute for `cl-define-setf-method' that works +This macro is an easy-to-use substitute for `cl-define-setf-expander' that works well for simple place forms. In the simple `cl-defsetf' form, `cl-setf's of the form (cl-setf (NAME ARGS...) VAL) are transformed to function or macro calls of the form (FUNC ARGS... VAL). Example: @@ -1990,7 +1978,7 @@ Example: lets2 (cons (list (car p1) (car p2)) lets2) p1 (cdr p1) p2 (cdr p2)))) (if restarg (setq lets2 (cons (list restarg rest-temps) lets2))) - `(cl-define-setf-method ,func ,arg1 + `(cl-define-setf-expander ,func ,arg1 ,@(and docstr (list docstr)) (let* ,(nreverse @@ -2143,7 +2131,7 @@ Example: ;; (setq a 7) or (setq a nil) depending on whether B is nil or not. ;; 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-method eq (place val) +(cl-define-setf-expander eq (place val) (let ((method (cl-get-setf-method place cl-macro-environment)) (val-temp (make-symbol "--eq-val--")) (store-temp (make-symbol "--eq-store--"))) @@ -2160,7 +2148,7 @@ Example: ;; available while compiling cl-macs, we fake it by referring to the global ;; variable cl-macro-environment directly. -(cl-define-setf-method apply (func arg1 &rest rest) +(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)) @@ -2177,7 +2165,7 @@ Example: (error "%s is not suitable for use with setf-of-apply" func)) `(apply ',(car form) ,@(cdr form)))) -(cl-define-setf-method nthcdr (n place) +(cl-define-setf-expander nthcdr (n place) (let ((method (cl-get-setf-method place cl-macro-environment)) (n-temp (make-symbol "--cl-nthcdr-n--")) (store-temp (make-symbol "--cl-nthcdr-store--"))) @@ -2190,7 +2178,7 @@ Example: ,(nth 3 method) ,store-temp) `(nthcdr ,n-temp ,(nth 4 method))))) -(cl-define-setf-method cl-getf (place tag &optional def) +(cl-define-setf-expander cl-getf (place tag &optional def) (let ((method (cl-get-setf-method place cl-macro-environment)) (tag-temp (make-symbol "--cl-getf-tag--")) (def-temp (make-symbol "--cl-getf-def--")) @@ -2203,7 +2191,7 @@ Example: ,(nth 3 method) ,store-temp) `(cl-getf ,(nth 4 method) ,tag-temp ,def-temp)))) -(cl-define-setf-method substring (place from &optional to) +(cl-define-setf-expander substring (place from &optional to) (let ((method (cl-get-setf-method place cl-macro-environment)) (from-temp (make-symbol "--cl-substring-from--")) (to-temp (make-symbol "--cl-substring-to--")) @@ -2257,12 +2245,12 @@ a macro like `cl-setf' or `cl-incf'." (lets nil) (subs nil) (optimize (and (not (eq opt-expr 'no-opt)) (or (and (not (eq opt-expr 'unsafe)) - (cl-safe-expr-p opt-expr)) + (cl--safe-expr-p opt-expr)) (cl-setf-simple-store-p (car (nth 2 method)) (nth 3 method))))) - (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place))))) + (simple (and optimize (consp place) (cl--simple-exprs-p (cdr place))))) (while values - (if (or simple (cl-const-expr-p (car values))) + (if (or simple (macroexp-const-p (car values))) (push (cons (pop temps) (pop values)) subs) (push (list (pop temps) (pop values)) lets))) (list (nreverse lets) @@ -2272,14 +2260,14 @@ a macro like `cl-setf' or `cl-incf'." (defun cl-setf-do-store (spec val) (let ((sym (car spec)) (form (cdr spec))) - (if (or (cl-const-expr-p val) - (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1)) + (if (or (macroexp-const-p val) + (and (cl--simple-expr-p val) (eq (cl--expr-contains form sym) 1)) (cl-setf-simple-store-p sym form)) (cl-subst val sym form) `(let ((,sym ,val)) ,form)))) (defun cl-setf-simple-store-p (sym form) - (and (consp form) (eq (cl-expr-contains form sym) 1) + (and (consp form) (eq (cl--expr-contains form sym) 1) (eq (nth (1- (length form)) form) sym) (symbolp (car form)) (fboundp (car form)) (not (eq (car-safe (symbol-function (car form))) 'macro)))) @@ -2315,7 +2303,7 @@ before assigning any PLACEs to the corresponding values. (declare (debug cl-setf)) (let ((p args) (simple t) (vars nil)) (while p - (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars)) + (if (or (not (symbolp (car p))) (cl--expr-depends-p (nth 1 p) vars)) (setq simple nil)) (if (memq (car p) vars) (error "Destination duplicated in psetf: %s" (car p))) @@ -2332,7 +2320,7 @@ before assigning any PLACEs to the corresponding values. ;;;###autoload (defun cl-do-pop (place) - (if (cl-simple-expr-p place) + (if (cl--simple-expr-p place) `(prog1 (car ,place) (cl-setf ,place (cdr ,place))) (let* ((method (cl-setf-do-modify place t)) (temp (make-symbol "--cl-pop--"))) @@ -2348,8 +2336,8 @@ PLACE may be a symbol, or any generalized variable allowed by `cl-setf'. The form returns true if TAG was found and removed, nil otherwise." (declare (debug (place form))) (let* ((method (cl-setf-do-modify place t)) - (tag-temp (and (not (cl-const-expr-p tag)) (make-symbol "--cl-remf-tag--"))) - (val-temp (and (not (cl-simple-expr-p place)) + (tag-temp (and (not (macroexp-const-p tag)) (make-symbol "--cl-remf-tag--"))) + (val-temp (and (not (cl--simple-expr-p place)) (make-symbol "--cl-remf-place--"))) (ttag (or tag-temp tag)) (tval (or val-temp (nth 2 method)))) @@ -2431,7 +2419,7 @@ the PLACE is not modified before executing BODY. (save (make-symbol "--cl-letf-save--")) (bound (and (memq (car place) '(symbol-value symbol-function)) (make-symbol "--cl-letf-bound--"))) - (temp (and (not (cl-const-expr-p value)) (cdr bindings) + (temp (and (not (macroexp-const-p value)) (cdr bindings) (make-symbol "--cl-letf-val--")))) (setq lets (nconc (car method) (if bound @@ -2506,10 +2494,10 @@ Like `cl-callf', but PLACE is the second argument of FUNC, not the first. \(fn FUNC ARG1 PLACE ARGS...)" (declare (indent 3) (debug (cl-function form place &rest form))) - (if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func)) + (if (and (cl--safe-expr-p arg1) (cl--simple-expr-p place) (symbolp func)) `(cl-setf ,place (,func ,arg1 ,place ,@args)) (let* ((method (cl-setf-do-modify place (cons 'list args))) - (temp (and (not (cl-const-expr-p arg1)) (make-symbol "--cl-arg1--"))) + (temp (and (not (macroexp-const-p arg1)) (make-symbol "--cl-arg1--"))) (rargs (cl-list* (or temp arg1) (nth 2 method) args))) `(let* (,@(and temp (list (list temp arg1))) ,@(car method)) ,(cl-setf-do-store (nth 1 method) @@ -2530,7 +2518,7 @@ from ARGLIST using FUNC: (cl-define-modify-macro cl-incf (&optional (n 1)) +)" ,doc (,(if (memq '&rest arglist) #'cl-list* #'list) #'cl-callf ',func ,place - ,@(cl-arglist-args arglist))))) + ,@(cl--arglist-args arglist))))) ;;; Structures. @@ -2715,7 +2703,7 @@ value, that slot cannot be set via `cl-setf'. (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))))) forms) (push (cons accessor t) side-eff) - (push `(cl-define-setf-method ,accessor (cl-x) + (push `(cl-define-setf-expander ,accessor (cl-x) ,(if (cadr (memq :read-only (cddr desc))) `(progn (ignore cl-x) (error "%s is a read-only slot" @@ -2756,13 +2744,13 @@ value, that slot cannot be set via `cl-setf'. (while constrs (let* ((name (caar constrs)) (args (cadr (pop constrs))) - (anames (cl-arglist-args args)) + (anames (cl--arglist-args args)) (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) (push `(cl-defsubst ,name (&cl-defs '(nil ,@descs) ,@args) (,type ,@make)) forms) - (if (cl-safe-expr-p `(progn ,@(mapcar #'cl-second descs))) + (if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) (push (cons name t) side-eff)))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) (if print-func @@ -2816,13 +2804,13 @@ value, that slot cannot be set via `cl-setf'. The type name can then be used in `cl-typecase', `cl-check-type', etc." (declare (debug cl-defmacro) (doc-string 3)) `(cl-eval-when (compile load eval) - ,(cl-transform-function-property + ,(cl--transform-function-property name 'cl-deftype-handler (cons `(&cl-defs '('*) ,@arglist) body)))) -(defun cl-make-type-test (val type) +(defun cl--make-type-test (val type) (if (symbolp type) (cond ((get type 'cl-deftype-handler) - (cl-make-type-test val (funcall (get type 'cl-deftype-handler)))) + (cl--make-type-test val (funcall (get type 'cl-deftype-handler)))) ((memq type '(nil t)) type) ((eq type 'null) `(null ,val)) ((eq type 'atom) `(atom ,val)) @@ -2837,10 +2825,10 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (if (fboundp namep) (list namep val) (list (intern (concat name "-p")) val))))) (cond ((get (car type) 'cl-deftype-handler) - (cl-make-type-test val (apply (get (car type) 'cl-deftype-handler) + (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler) (cdr type)))) ((memq (car type) '(integer float real number)) - (delq t `(and ,(cl-make-type-test val (car type)) + (delq t `(and ,(cl--make-type-test val (car type)) ,(if (memq (cadr type) '(* nil)) t (if (consp (cadr type)) `(> ,val ,(cl-caadr type)) `(>= ,val ,(cadr type)))) @@ -2849,7 +2837,7 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." `(<= ,val ,(cl-caddr type))))))) ((memq (car type) '(and or not)) (cons (car type) - (mapcar (function (lambda (x) (cl-make-type-test val x))) + (mapcar (function (lambda (x) (cl--make-type-test val x))) (cdr type)))) ((memq (car type) '(member cl-member)) `(and (cl-member ,val ',(cdr type)) t)) @@ -2860,7 +2848,7 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (defun cl-typep (object type) ; See compiler macro below. "Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier." - (eval (cl-make-type-test 'object type))) + (eval (cl--make-type-test 'object type))) ;;;###autoload (defmacro cl-check-type (form type &optional string) @@ -2869,9 +2857,9 @@ STRING is an optional description of the desired type." (declare (debug (place cl-type-spec &optional stringp))) (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) - (let* ((temp (if (cl-simple-expr-p form 3) + (let* ((temp (if (cl--simple-expr-p form 3) form (make-symbol "--cl-var--"))) - (body `(or ,(cl-make-type-test temp type) + (body `(or ,(cl--make-type-test temp type) (signal 'wrong-type-argument (list ,(or string `',type) ,temp ',form))))) @@ -2889,11 +2877,10 @@ omitted, a default message listing FORM itself is used." (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) (let ((sargs (and show-args - (delq nil (mapcar - (lambda (x) - (unless (cl-const-expr-p x) - x)) - (cdr form)))))) + (delq nil (mapcar (lambda (x) + (unless (macroexp-const-p x) + x)) + (cdr form)))))) `(progn (or ,form ,(if string @@ -2921,7 +2908,7 @@ and then returning foo." (while (consp p) (push (pop p) res)) (setq args (nconc (nreverse res) (and p (list '&rest p))))) `(cl-eval-when (compile load eval) - ,(cl-transform-function-property + ,(cl--transform-function-property func 'compiler-macro (cons (if (memq '&whole args) (delq '&whole args) (cons '_cl-whole-arg args)) body)) @@ -2948,18 +2935,13 @@ and then returning foo." (not (eq form (setq form (apply handler form (cdr form)))))))) form) -(defun cl-byte-compile-compiler-macro (form) - (if (eq form (setq form (cl-compiler-macroexpand form))) - (byte-compile-normal-call form) - (byte-compile-form form))) - ;; Optimize away unused block-wrappers. -(defvar cl-active-block-names nil) +(defvar cl--active-block-names nil) (cl-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--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))) @@ -2970,7 +2952,7 @@ and then returning foo." cl-body))) (cl-define-compiler-macro cl-block-throw (cl-tag cl-value) - (let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names))) + (let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names))) (if cl-found (setcdr cl-found t))) `(throw ,cl-tag ,cl-value)) @@ -2983,10 +2965,10 @@ surrounded by (cl-block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug cl-defun)) - (let* ((argns (cl-arglist-args args)) (p argns) + (let* ((argns (cl--arglist-args args)) (p argns) (pbody (cons 'progn body)) - (unsafe (not (cl-safe-expr-p pbody)))) - (while (and p (eq (cl-expr-contains args (car p)) 1)) (pop p)) + (unsafe (not (cl--safe-expr-p pbody)))) + (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p)) `(progn ,(if p nil ; give up if defaults refer to earlier args `(cl-define-compiler-macro ,name @@ -3005,12 +2987,12 @@ surrounded by (cl-block NAME ...). (cl-defun ,name ,args ,@body)))) (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) - (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole - (if (cl-simple-exprs-p argvs) (setq simple t)) + (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole + (if (cl--simple-exprs-p argvs) (setq simple t)) (let* ((substs ()) (lets (delq nil (cl-mapcar (lambda (argn argv) - (if (or simple (cl-const-expr-p argv)) + (if (or simple (macroexp-const-p argv)) (progn (push (cons argn argv) substs) (and unsafe (list argn argv))) (list argn argv))) @@ -3033,22 +3015,22 @@ surrounded by (cl-block NAME ...). (put 'eql 'byte-compile nil) (cl-define-compiler-macro eql (&whole form a b) - (cond ((eq (cl-const-expr-p a) t) - (let ((val (cl-const-expr-val a))) + (cond ((macroexp-const-p a) + (let ((val (cl--const-expr-val a))) (if (and (numberp val) (not (integerp val))) `(equal ,a ,b) `(eq ,a ,b)))) - ((eq (cl-const-expr-p b) t) - (let ((val (cl-const-expr-val b))) + ((macroexp-const-p b) + (let ((val (cl--const-expr-val b))) (if (and (numberp val) (not (integerp val))) `(equal ,a ,b) `(eq ,a ,b)))) - ((cl-simple-expr-p a 5) + ((cl--simple-expr-p a 5) `(if (numberp ,a) (equal ,a ,b) (eq ,a ,b))) - ((and (cl-safe-expr-p a) - (cl-simple-expr-p b 5)) + ((and (cl--safe-expr-p a) + (cl--simple-expr-p b 5)) `(if (numberp ,b) (equal ,a ,b) (eq ,a ,b))) @@ -3056,7 +3038,7 @@ surrounded by (cl-block NAME ...). (cl-define-compiler-macro cl-member (&whole form a list &rest keys) (let ((test (and (= (length keys) 2) (eq (car keys) :test) - (cl-const-expr-val (nth 1 keys))))) + (cl--const-expr-val (nth 1 keys))))) (cond ((eq test 'eq) `(memq ,a ,list)) ((eq test 'equal) `(member ,a ,list)) ((or (null keys) (eq test 'eql)) `(memql ,a ,list)) @@ -3064,16 +3046,16 @@ surrounded by (cl-block NAME ...). (cl-define-compiler-macro cl-assoc (&whole form a list &rest keys) (let ((test (and (= (length keys) 2) (eq (car keys) :test) - (cl-const-expr-val (nth 1 keys))))) + (cl--const-expr-val (nth 1 keys))))) (cond ((eq test 'eq) `(assq ,a ,list)) ((eq test 'equal) `(assoc ,a ,list)) - ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql))) - (if (cl-floatp-safe (cl-const-expr-val a)) + ((and (macroexp-const-p a) (or (null keys) (eq test 'eql))) + (if (cl-floatp-safe (cl--const-expr-val a)) `(assoc ,a ,list) `(assq ,a ,list))) (t form)))) (cl-define-compiler-macro cl-adjoin (&whole form a list &rest keys) - (if (and (cl-simple-expr-p a) (cl-simple-expr-p list) + (if (and (cl--simple-expr-p a) (cl--simple-expr-p list) (not (memq :key keys))) `(if (cl-member ,a ,list ,@keys) ,list (cons ,a ,list)) form)) @@ -3091,10 +3073,10 @@ surrounded by (cl-block NAME ...). `(get ,sym ,prop))) (cl-define-compiler-macro cl-typep (&whole form val type) - (if (cl-const-expr-p type) - (let ((res (cl-make-type-test val (cl-const-expr-val type)))) - (if (or (memq (cl-expr-contains res val) '(nil 1)) - (cl-simple-expr-p val)) res + (if (macroexp-const-p type) + (let ((res (cl--make-type-test val (cl--const-expr-val type)))) + (if (or (memq (cl--expr-contains res val) '(nil 1)) + (cl--simple-expr-p val)) res (let ((temp (make-symbol "--cl-var--"))) `(let ((,temp ,val)) ,(cl-subst temp val res))))) form)) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 14eb15fa578..ad15d038a81 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -219,8 +219,8 @@ setf get-setf-method defsetf + (define-setf-method . cl-define-setf-expander) define-setf-expander - define-setf-method declare the locally diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 506a737d36d..ba720b42868 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -35,6 +35,8 @@ ;;; Code: +(require 'macroexp) + ;;; The variable byte-code-vector is defined by the new bytecomp.el. ;;; The function byte-decompile-lapcode is defined in byte-opt.el. ;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. @@ -155,7 +157,7 @@ redefine OBJECT if it is a symbol." (t (insert "Uncompiled body: ") (let ((print-escape-newlines t)) - (prin1 (if (cdr obj) (cons 'progn obj) (car obj)) + (prin1 (macroexp-progn obj) (current-buffer)))))) (if interactive-p (message ""))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index ee5e5d0ff89..8c6738ca6a9 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -51,6 +51,8 @@ ;;; Code: +(require 'macroexp) + ;;; Bug reporting (defalias 'edebug-submit-bug-report 'report-emacs-bug) @@ -1251,10 +1253,7 @@ expressions; a `progn' form will be returned enclosing these forms." ((eq 'edebug-after (car sexp)) (nth 3 sexp)) ((eq 'edebug-enter (car sexp)) - (let ((forms (nthcdr 2 (nth 1 (nth 3 sexp))))) - (if (> (length forms) 1) - (cons 'progn forms) ;; could return (values forms) instead. - (car forms)))) + (macroexp-progn (nthcdr 2 (nth 1 (nth 3 sexp))))) (t sexp);; otherwise it is not wrapped, so just return it. ) sexp)) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 7c413c7366f..115af33fb6c 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -225,6 +225,84 @@ definitions to shadow the loaded ones for use in file byte-compilation." (let ((macroexpand-all-environment environment)) (macroexp--expand-all form))) +;;; Handy functions to use in macros. + +(defun macroexp-progn (exps) + "Return an expression equivalent to `(progn ,@EXPS)." + (if (cdr exps) `(progn ,@exps) (car exps))) + +(defun macroexp-let* (bindings exp) + "Return an expression equivalent to `(let* ,bindings ,exp)." + (cond + ((null bindings) exp) + ((eq 'let* (car-safe exp)) `(let* (,@bindings ,@(cadr exp)) ,@(cddr exp))) + (t `(let* ,bindings ,exp)))) + +(defun macroexp-if (test then else) + "Return an expression equivalent to `(if ,test ,then ,else)." + (cond + ((eq (car-safe else) 'if) + (if (equal test (nth 1 else)) + ;; Doing a test a second time: get rid of the redundancy. + `(if ,test ,then ,@(nthcdr 3 else)) + `(cond (,test ,then) + (,(nth 1 else) ,(nth 2 else)) + (t ,@(nthcdr 3 else))))) + ((eq (car-safe else) 'cond) + `(cond (,test ,then) + ;; Doing a test a second time: get rid of the redundancy, as above. + ,@(remove (assoc test else) (cdr else)))) + ;; Invert the test if that lets us reduce the depth of the tree. + ((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then)) + (t `(if ,test ,then ,else)))) + +(defmacro macroexp-let² (test var exp &rest exps) + "Bind VAR to a copyable expression that returns the value of EXP. +This is like `(let ((v ,EXP)) ,EXPS) except that `v' is a new generated +symbol which EXPS can find in VAR. +TEST should be the name of a predicate on EXP checking whether the `let' can +be skipped; if nil, as is usual, `macroexp-const-p' is used." + (declare (indent 3) (debug (sexp form sexp body))) + (let ((bodysym (make-symbol "body")) + (expsym (make-symbol "exp"))) + `(let* ((,expsym ,exp) + (,var (if (,(or test #'macroexp-const-p) ,expsym) + ,expsym (make-symbol "x"))) + (,bodysym ,(macroexp-progn exps))) + (if (eq ,var ,expsym) ,bodysym + (macroexp-let* (list (list ,var ,expsym)) + ,bodysym))))) + +(defsubst macroexp--const-symbol-p (symbol &optional any-value) + "Non-nil if SYMBOL is constant. +If ANY-VALUE is nil, only return non-nil if the value of the symbol is the +symbol itself." + (or (memq symbol '(nil t)) + (keywordp symbol) + (if any-value + (or (memq symbol byte-compile-const-variables) + ;; FIXME: We should provide a less intrusive way to find out + ;; if a variable is "constant". + (and (boundp symbol) + (condition-case nil + (progn (set symbol (symbol-value symbol)) nil) + (setting-constant t))))))) + +(defun macroexp-const-p (exp) + "Return non-nil if EXP will always evaluate to the same value." + (cond ((consp exp) (or (eq (car exp) 'quote) + (and (eq (car exp) 'function) + (symbolp (cadr exp))))) + ;; It would sometimes make sense to pass `any-value', but it's not + ;; always safe since a "constant" variable may not actually always have + ;; the same value. + ((symbolp exp) (macroexp--const-symbol-p exp)) + (t t))) + +(defun macroexp-copyable-p (exp) + "Return non-nil if EXP can be copied without extra cost." + (or (symbolp exp) (macroexp-const-p exp))) + (provide 'macroexp) ;;; macroexp.el ends here diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 9f98b30adae..67f4c4af7e7 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -53,6 +53,8 @@ ;;; Code: +(require 'macroexp) + ;; Macro-expansion of pcase is reasonably fast, so it's not a problem ;; when byte-compiling a file, but when interpreting the code, if the pcase ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we @@ -94,7 +96,7 @@ PRED patterns can refer to variables bound earlier in the pattern. E.g. you can match pairs where the cdr is larger than the car with a pattern like `(,a . ,(pred (< a))) or, with more checks: `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" - (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars. + (declare (indent 1) (debug cl-case)) ;FIXME: edebug `guard' and vars. ;; We want to use a weak hash table as a cache, but the key will unavoidably ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time ;; we're called so it'll be immediately GC'd. So we use (car cases) as key @@ -225,10 +227,10 @@ of the form (UPAT EXP)." (cdr case)))) cases)))) (if (null defs) main - (pcase--let* defs main)))) + (macroexp-let* defs main)))) (defun pcase-codegen (code vars) - ;; Don't use let*, otherwise pcase--let* may merge it with some surrounding + ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy ;; codegen from later metamorphosing this let into a funcall. `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) @@ -248,30 +250,7 @@ of the form (UPAT EXP)." (cond ((eq else :pcase--dontcare) then) ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen? - ((eq (car-safe else) 'if) - (if (equal test (nth 1 else)) - ;; Doing a test a second time: get rid of the redundancy. - ;; FIXME: ideally, this should never happen because the pcase--split-* - ;; funs should have eliminated such things, but pcase--split-member - ;; is imprecise, so in practice it can happen occasionally. - `(if ,test ,then ,@(nthcdr 3 else)) - `(cond (,test ,then) - (,(nth 1 else) ,(nth 2 else)) - (t ,@(nthcdr 3 else))))) - ((eq (car-safe else) 'cond) - `(cond (,test ,then) - ;; Doing a test a second time: get rid of the redundancy, as above. - ,@(remove (assoc test else) (cdr else)))) - ;; Invert the test if that lets us reduce the depth of the tree. - ((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then)) - (t `(if ,test ,then ,else)))) - -;; Again, try and reduce nesting. -(defun pcase--let* (binders body) - (if (eq (car-safe body) 'let*) - `(let* ,(append binders (nth 1 body)) - ,@(nthcdr 2 body)) - `(let* ,binders ,body))) + (t (macroexp-if test then else)))) (defun pcase--upat (qpattern) (cond @@ -589,21 +568,17 @@ Otherwise, it defers to REST which is a list of branches of the form ;; A upat of the form (let VAR EXP). ;; (pcase--u1 matches code ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest) - (let* ((exp - (let* ((exp (nth 2 upat)) - (found (assq exp vars))) - (if found (cdr found) - (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) - (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) - vs))) - (if env `(let* ,env ,exp) exp))))) - (sym (if (symbolp exp) exp (make-symbol "x"))) - (body - (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) - code vars rest))) - (if (eq sym exp) - body - `(let* ((,sym ,exp)) ,body)))) + (macroexp-let² + macroexp-copyable-p sym + (let* ((exp (nth 2 upat)) + (found (assq exp vars))) + (if found (cdr found) + (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) + (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) + vs))) + (if env (macroexp-let* env exp) exp)))) + (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) + code vars rest))) ((eq (car-safe upat) '\`) (put sym 'pcase-used t) (pcase--q1 sym (cadr upat) matches code vars rest)) @@ -695,7 +670,7 @@ Otherwise, it defers to REST which is a list of branches of the form ;; can't signal errors and our byte-compiler is not that clever. ;; FIXME: Some of those let bindings occur too early (they are used in ;; `then-body', but only within some sub-branch). - (pcase--let* + (macroexp-let* `(,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) then-body) diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 02d37f86da0..6ec5e2302a2 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -30,8 +30,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) ; letf - (defvar dos-codepage) (autoload 'widget-value "wid-edit") @@ -285,7 +283,7 @@ wrong, use this command again to toggle back to the right mode." "Display the HELLO file, which lists many languages and characters." (interactive) ;; We have to decode the file in any environment. - (letf ((coding-system-for-read 'iso-2022-7bit)) + (let ((coding-system-for-read 'iso-2022-7bit)) (view-file (expand-file-name "HELLO" data-directory)))) (defun universal-coding-system-argument (coding-system)