-;;; cl-macs.el --- Common Lisp macros
+;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t; coding: utf-8 -*-
;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
(require 'cl-lib)
(require 'macroexp)
+;; `gv' is required here because cl-macs can be loaded before loaddefs.el.
+(require 'gv)
(defmacro cl-pop2 (place)
(declare (debug edebug-sexps))
(defvar cl-optimize-safety)
(defvar cl-optimize-speed)
-
-;; 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)
- `(put ',n ',p #'(lambda . ,f)))))
-
;;; Initialization.
;;; Some predicates for analyzing Lisp forms.
(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
- ;; the variables V in the same order as they appear in V (so as to
- ;; be able to replace those vars with the expressions they're bound
- ;; to).
- ;; FIXME: This is very naive, it doesn't even check to see if those
- ;; variables appear more than once.
- (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)))))
-
(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
(def-edebug-spec cl-&key-arg
(&or ([&or (symbolp arg) arg] &optional def-form arg) arg))
+(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)
+
+(defun cl--transform-lambda (form bind-block)
+ (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 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))
+ (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)
"Define NAME as a function.
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug
;; Same as defun but use cl-lambda-list.
- (&define [&or name ("cl-setf" :name cl-setf name)]
+ (&define [&or name ("setf" :name setf name)]
cl-lambda-list
cl-declarations-or-string
[&optional ("interactive" interactive)]
(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)))
- `(progn ,@(cdr (cdr (car res)))
- (put ',func ',prop #'(lambda . ,(cdr res))))))
-
-(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)
-
(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
(defun cl--make-usage-var (x)
(t x)))
(defun cl--make-usage-args (arglist)
- ;; `orig-args' can contain &cl-defs (an internal
- ;; CL thingy I don't understand), so remove it.
- (let ((x (memq '&cl-defs arglist)))
- (when x (setq arglist (delq (car x) (remq (cadr x) arglist)))))
- (let ((state nil))
- (mapcar (lambda (x)
- (cond
- ((symbolp x)
- (if (eq ?\& (aref (symbol-name x) 0))
- (setq state x)
- (make-symbol (upcase (symbol-name x)))))
- ((not (consp x)) x)
- ((memq state '(nil &rest)) (cl--make-usage-args x))
- (t ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR).
- (cl-list*
- (if (and (consp (car x)) (eq state '&key))
- (list (caar x) (cl--make-usage-var (nth 1 (car x))))
- (cl--make-usage-var (car x)))
- (nth 1 x) ;INITFORM.
- (cl--make-usage-args (nthcdr 2 x)) ;SVAR.
- ))))
- arglist)))
-
-(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)
- (header nil) (simple-args nil))
- (while (or (stringp (car body))
- (memq (car-safe (car body)) '(interactive 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))
- (format "%S"
- (cons 'fn
- (cl--make-usage-args orig-args))))
- hdr)))
- (list `(let* ,cl-bind-lets
- ,@(nreverse cl-bind-forms)
- ,@body)))))))
+ (if (cdr-safe (last arglist)) ;Not a proper list.
+ (let* ((last (last arglist))
+ (tail (cdr last)))
+ (unwind-protect
+ (progn
+ (setcdr last nil)
+ (nconc (cl--make-usage-args arglist) (cl--make-usage-var tail)))
+ (setcdr last tail)))
+ ;; `orig-args' can contain &cl-defs (an internal
+ ;; CL thingy I don't understand), so remove it.
+ (let ((x (memq '&cl-defs arglist)))
+ (when x (setq arglist (delq (car x) (remq (cadr x) arglist)))))
+ (let ((state nil))
+ (mapcar (lambda (x)
+ (cond
+ ((symbolp x)
+ (if (eq ?\& (aref (symbol-name x) 0))
+ (setq state x)
+ (make-symbol (upcase (symbol-name x)))))
+ ((not (consp x)) x)
+ ((memq state '(nil &rest)) (cl--make-usage-args x))
+ (t ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR).
+ (cl-list*
+ (if (and (consp (car x)) (eq state '&key))
+ (list (caar x) (cl--make-usage-var (nth 1 (car x))))
+ (cl--make-usage-var (car x)))
+ (nth 1 x) ;INITFORM.
+ (cl--make-usage-args (nthcdr 2 x)) ;SVAR.
+ ))))
+ arglist))))
(defun cl--do-arglist (args expr &optional num) ; uses bind-*
(if (nlistp args)
- (if (or (memq args cl-lambda-list-keywords) (not (symbolp args)))
+ (if (or (memq args cl--lambda-list-keywords) (not (symbolp args)))
(error "Invalid argument name: %s" args)
- (push (list args expr) cl-bind-lets))
+ (push (list args expr) cl--bind-lets))
(setq args (cl-copy-list args))
(let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
(let ((p (memq '&body args))) (if p (setcar p '&rest)))
(if (memq '&environment args) (error "&environment used incorrectly"))
(let ((save-args args)
(restarg (memq '&rest args))
- (safety (if (cl-compiling-file) cl-optimize-safety 3))
+ (safety (if (cl--compiling-file) cl-optimize-safety 3))
(keys nil)
(laterarg nil) (exactarg nil) minarg)
(or num (setq num 0))
(if (listp (cadr restarg))
(setq restarg (make-symbol "--cl-rest--"))
(setq restarg (cadr restarg)))
- (push (list restarg expr) cl-bind-lets)
+ (push (list restarg expr) cl--bind-lets)
(if (eq (car args) '&whole)
- (push (list (cl-pop2 args) restarg) cl-bind-lets))
+ (push (list (cl-pop2 args) restarg) cl--bind-lets))
(let ((p args))
(setq minarg restarg)
- (while (and p (not (memq (car p) cl-lambda-list-keywords)))
+ (while (and p (not (memq (car p) cl--lambda-list-keywords)))
(or (eq p args) (setq minarg (list 'cdr minarg)))
(setq p (cdr p)))
(if (memq (car p) '(nil &aux))
(setq minarg `(= (length ,restarg)
,(length (cl-ldiff args p)))
exactarg (not (eq args p)))))
- (while (and args (not (memq (car args) cl-lambda-list-keywords)))
+ (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
(if (or laterarg (= safety 0)) poparg
`(if ,minarg ,poparg
(signal 'wrong-number-of-arguments
- (list ,(and (not (eq cl-bind-block 'cl-none))
- `',cl-bind-block)
+ (list ,(and (not (eq cl--bind-block 'cl-none))
+ `',cl--bind-block)
(length ,restarg)))))))
(setq num (1+ num) laterarg t))
(while (and (eq (car args) '&optional) (pop args))
- (while (and args (not (memq (car args) cl-lambda-list-keywords)))
+ (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)))
(let ((def (if (cdr arg) (nth 1 arg)
- (or (car cl-bind-defs)
- (nth 1 (assq (car arg) cl-bind-defs)))))
+ (or (car cl--bind-defs)
+ (nth 1 (assq (car arg) cl--bind-defs)))))
(poparg `(pop ,restarg)))
- (and def cl-bind-enquote (setq def `',def))
+ (and def cl--bind-enquote (setq def `',def))
(cl--do-arglist (car arg)
(if def `(if ,restarg ,poparg ,def) poparg))
(setq num (1+ num))))))
(push `(if ,restarg
(signal 'wrong-number-of-arguments
(list
- ,(and (not (eq cl-bind-block 'cl-none))
- `',cl-bind-block)
+ ,(and (not (eq cl--bind-block 'cl-none))
+ `',cl--bind-block)
(+ ,num (length ,restarg)))))
- cl-bind-forms)))
+ cl--bind-forms)))
(while (and (eq (car args) '&key) (pop args))
- (while (and args (not (memq (car args) cl-lambda-list-keywords)))
+ (while (and args (not (memq (car args) cl--lambda-list-keywords)))
(let ((arg (pop args)))
(or (consp arg) (setq arg (list arg)))
(let* ((karg (if (consp (car arg)) (caar arg)
(intern (format ":%s" (car arg)))))
(varg (if (consp (car arg)) (cl-cadar arg) (car arg)))
(def (if (cdr arg) (cadr arg)
- (or (car cl-bind-defs) (cadr (assq varg cl-bind-defs)))))
+ (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs)))))
(look `(memq ',karg ,restarg)))
- (and def cl-bind-enquote (setq def `',def))
+ (and def cl--bind-enquote (setq def `',def))
(if (cddr arg)
(let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
(val `(car (cdr ,temp))))
,(format "Keyword argument %%s not one of %s"
keys)
(car ,var)))))))
- (push `(let ((,var ,restarg)) ,check) cl-bind-forms)))
+ (push `(let ((,var ,restarg)) ,check) cl--bind-forms)))
(while (and (eq (car args) '&aux) (pop args))
- (while (and args (not (memq (car args) cl-lambda-list-keywords)))
+ (while (and args (not (memq (car args) cl--lambda-list-keywords)))
(if (consp (car args))
- (if (and cl-bind-enquote (cl-cadar args))
+ (if (and cl--bind-enquote (cl-cadar args))
(cl--do-arglist (caar args)
`',(cadr (pop args)))
(cl--do-arglist (caar args) (cadr (pop 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 (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)))
(defmacro cl-destructuring-bind (args expr &rest body)
(declare (indent 2)
(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))
+ (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)
- (append '(progn) cl-bind-inits
- (list `(let* ,(nreverse cl-bind-lets)
- ,@(nreverse cl-bind-forms) ,@body)))))
+ (append '(progn) cl--bind-inits
+ (list `(let* ,(nreverse cl--bind-lets)
+ ,@(nreverse cl--bind-forms) ,@body)))))
;;; The `cl-eval-when' form.
\(fn (WHEN...) BODY...)"
(declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body)))
- (if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
+ (if (and (fboundp 'cl--compiling-file) (cl--compiling-file)
(not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge
(let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
(cl-not-toplevel t))
(t (eval form) form)))
;;;###autoload
-(defmacro cl-load-time-value (form &optional read-only)
+(defmacro cl-load-time-value (form &optional _read-only)
"Like `progn', but evaluates the body at load time.
The result of the body appears to the compiler as a quoted constant."
(declare (debug (form &optional sexp)))
- (if (cl-compiling-file)
+ (if (cl--compiling-file)
(let* ((temp (cl-gentemp "--cl-load-time--"))
(set `(set ',temp ,form)))
(if (and (fboundp 'byte-compile-file-form-defmumble)
;;;###autoload
(defmacro cl-ecase (expr &rest clauses)
- "Like `cl-case', but error if no cl-case fits.
+ "Like `cl-case', but error if no case fits.
`otherwise'-clauses are not allowed.
\n(fn EXPR (KEYLIST BODY...)...)"
(declare (indent 1) (debug cl-case))
called from BODY."
(declare (indent 1) (debug (symbolp body)))
(if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body)
- `(cl-block-wrapper
+ `(cl--block-wrapper
(catch ',(intern (format "--cl-block-%s--" name))
,@body))))
`defmacro' do not create implicit blocks as they do in Common Lisp."
(declare (indent 1) (debug (symbolp &optional form)))
(let ((name2 (intern (format "--cl-block-%s--" name))))
- `(cl-block-throw ',name2 ,result)))
+ `(cl--block-throw ',name2 ,result)))
;;; The "cl-loop" macro.
(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 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,
finally return EXPR, named NAME.
\(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)
+ (declare (debug (&rest &or
+ ;; These are usually followed by a symbol, but it can
+ ;; actually be any destructuring-bind pattern, which
+ ;; would erroneously match `form'.
+ [[&or "for" "as" "with" "and"] sexp]
+ ;; These are followed by expressions which could
+ ;; erroneously match `symbolp'.
+ [[&or "from" "upfrom" "downfrom" "to" "upto" "downto"
+ "above" "below" "by" "in" "on" "=" "across"
+ "repeat" "while" "until" "always" "never"
+ "thereis" "collect" "append" "nconc" "sum"
+ "count" "maximize" "minimize" "if" "unless"
+ "return"] form]
+ ;; Simple default, which covers 99% of the cases.
+ symbolp form)))
+ (if (not (memq t (mapcar 'symbolp (delq nil (delq t (cl-copy-list loop-args))))))
+ `(cl-block nil (while t ,@loop-args))
+ (let ((cl--loop-args loop-args) (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)
(let ((temp-len (make-symbol "--cl-len--")))
(push (list temp-len `(length ,temp-seq))
loop-for-bindings)
- (push (list var `(elt ,temp-seq temp-idx))
+ (push (list var `(elt ,temp-seq ,temp-idx))
cl--loop-symbol-macs)
(push `(< ,temp-idx ,temp-len) cl--loop-body))
(push (list var nil) loop-for-bindings)
((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
+ `(cl--map-overlays
(lambda (,var ,(make-symbol "--cl-var--"))
(progn . --cl-map) nil)
,buf ,from ,to))))
(setq var1 (car var) var2 (cdr var))
(push (list var `(cons ,var1 ,var2)) loop-for-sets))
(setq cl--loop-map-form
- `(cl-map-intervals
+ `(cl--map-intervals
(lambda (,var1 ,var2) . --cl-map)
,buf ,prop ,from ,to))))
(setq var (prog1 other (setq other var))))
(setq cl--loop-map-form
`(,(if (memq word '(key-seq key-seqs))
- 'cl-map-keymap-recursively 'map-keymap)
+ 'cl--map-keymap-recursively 'map-keymap)
(lambda (,var ,other) . --cl-map) ,cl-map))))
((memq word '(frame frames screen screens))
An implicit nil block is established around the loop.
\(fn (VAR LIST [RESULT]) BODY...)"
- (declare (debug ((symbolp form &optional form) cl-declarations body)))
- (let ((temp (make-symbol "--cl-dolist-temp--")))
- ;; FIXME: Copy&pasted from subr.el.
- `(cl-block nil
- ;; This is not a reliable test, but it does not matter because both
- ;; semantics are acceptable, tho one is slightly faster with dynamic
- ;; scoping and the other is slightly faster (and has cleaner semantics)
- ;; with lexical scoping.
- ,(if lexical-binding
- `(let ((,temp ,(nth 1 spec)))
- (while ,temp
- (let ((,(car spec) (car ,temp)))
- ,@body
- (setq ,temp (cdr ,temp))))
- ,@(if (cdr (cdr spec))
- ;; FIXME: This let often leads to "unused var" warnings.
- `((let ((,(car spec) nil)) ,@(cdr (cdr spec))))))
- `(let ((,temp ,(nth 1 spec))
- ,(car spec))
- (while ,temp
- (setq ,(car spec) (car ,temp))
- ,@body
- (setq ,temp (cdr ,temp)))
- ,@(if (cdr (cdr spec))
- `((setq ,(car spec) nil) ,@(cddr spec))))))))
+ (declare (debug ((symbolp form &optional form) cl-declarations body))
+ (indent 1))
+ `(cl-block nil
+ (,(if (eq 'cl-dolist (symbol-function 'dolist)) 'cl--dolist 'dolist)
+ ,spec ,@body)))
;;;###autoload
(defmacro cl-dotimes (spec &rest body)
nil.
\(fn (VAR COUNT [RESULT]) BODY...)"
- (declare (debug cl-dolist))
- (let ((temp (make-symbol "--cl-dotimes-temp--"))
- (end (nth 1 spec)))
- ;; FIXME: Copy&pasted from subr.el.
- `(cl-block nil
- ;; This is not a reliable test, but it does not matter because both
- ;; semantics are acceptable, tho one is slightly faster with dynamic
- ;; scoping and the other has cleaner semantics.
- ,(if lexical-binding
- (let ((counter '--dotimes-counter--))
- `(let ((,temp ,end)
- (,counter 0))
- (while (< ,counter ,temp)
- (let ((,(car spec) ,counter))
- ,@body)
- (setq ,counter (1+ ,counter)))
- ,@(if (cddr spec)
- ;; FIXME: This let often leads to "unused var" warnings.
- `((let ((,(car spec) ,counter)) ,@(cddr spec))))))
- `(let ((,temp ,end)
- (,(car spec) 0))
- (while (< ,(car spec) ,temp)
- ,@body
- (cl-incf ,(car spec)))
- ,@(cdr (cdr spec)))))))
+ (declare (debug cl-dolist) (indent 1))
+ `(cl-block nil
+ (,(if (eq 'cl-dotimes (symbol-function 'dotimes)) 'cl--dotimes 'dotimes)
+ ,spec ,@body)))
;;;###autoload
(defmacro cl-do-symbols (spec &rest body)
BODY forms are executed and their result is returned. This is much like
a `let' form, except that the list of symbols can be computed at run-time."
(declare (indent 2) (debug (form form body)))
- `(let ((cl-progv-save nil))
- (unwind-protect
- (progn (cl-progv-before ,symbols ,values) ,@body)
- (cl-progv-after))))
+ (let ((bodyfun (make-symbol "cl--progv-body"))
+ (binds (make-symbol "binds"))
+ (syms (make-symbol "syms"))
+ (vals (make-symbol "vals")))
+ `(progn
+ (defvar ,bodyfun)
+ (let* ((,syms ,symbols)
+ (,vals ,values)
+ (,bodyfun (lambda () ,@body))
+ (,binds ()))
+ (while ,syms
+ (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds))
+ (eval (list 'let ,binds '(funcall ,bodyfun)))))))
+
+(defvar cl--labels-convert-cache nil)
+
+(defun cl--labels-convert (f)
+ "Special macro-expander to rename (function F) references in `cl-labels'."
+ (cond
+ ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked
+ ;; *after* handling `function', but we want to stop macroexpansion from
+ ;; being applied infinitely, so we use a cache to return the exact `form'
+ ;; being expanded even though we don't receive it.
+ ((eq f (car cl--labels-convert-cache)) (cdr cl--labels-convert-cache))
+ (t
+ (let ((found (assq f macroexpand-all-environment)))
+ (if (and found (ignore-errors
+ (eq (cadr (cl-caddr found)) 'cl-labels-args)))
+ (cadr (cl-caddr (cl-cadddr found)))
+ (let ((res `(function ,f)))
+ (setq cl--labels-convert-cache (cons f res))
+ res))))))
-;;; This should really have some way to shadow 'byte-compile properties, etc.
;;;###autoload
(defmacro cl-flet (bindings &rest body)
"Make temporary function definitions.
-This is an analogue of `let' that operates on the function cell of FUNC
-rather than its value cell. The FORMs are evaluated with the specified
-function definitions in place, then the definitions are undone (the FUNCs
-go back to their previous definitions, or lack thereof).
+Like `cl-labels' but the definitions are not recursive.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body)))
- `(cl-letf* ,(mapcar
- (lambda (x)
- (if (or (and (fboundp (car x))
- (eq (car-safe (symbol-function (car x))) 'macro))
- (cdr (assq (car x) macroexpand-all-environment)))
- (error "Use `cl-labels', not `cl-flet', to rebind macro names"))
- (let ((func `(cl-function
- (lambda ,(cadr x)
- (cl-block ,(car x) ,@(cddr x))))))
- (when (cl-compiling-file)
- ;; Bug#411. It would be nice to fix this.
- (and (get (car x) 'byte-compile)
- (error "Byte-compiling a redefinition of `%s' \
-will not work - use `cl-labels' instead" (symbol-name (car x))))
- ;; FIXME This affects the rest of the file, when it
- ;; should be restricted to the cl-flet body.
- (and (boundp 'byte-compile-function-environment)
- (push (cons (car x) (eval func))
- byte-compile-function-environment)))
- (list `(symbol-function ',(car x)) func)))
- bindings)
- ,@body))
+ (let ((binds ()) (newenv macroexpand-all-environment))
+ (dolist (binding bindings)
+ (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
+ (push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
+ (push (cons (car binding)
+ `(lambda (&rest cl-labels-args)
+ (cl-list* 'funcall ',var
+ cl-labels-args)))
+ newenv)))
+ `(let ,(nreverse binds)
+ ,@(macroexp-unprogn
+ (macroexpand-all
+ `(progn ,@body)
+ ;; Don't override lexical-let's macro-expander.
+ (if (assq 'function newenv) newenv
+ (cons (cons 'function #'cl--labels-convert) newenv)))))))
+
+;;;###autoload
+(defmacro cl-flet* (bindings &rest body)
+ "Make temporary function definitions.
+Like `cl-flet' but the definitions can refer to previous ones.
+
+\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
+ (declare (indent 1) (debug cl-flet))
+ (cond
+ ((null bindings) (macroexp-progn body))
+ ((null (cdr bindings)) `(cl-flet ,bindings ,@body))
+ (t `(cl-flet (,(pop bindings)) (cl-flet* ,bindings ,@body)))))
;;;###autoload
(defmacro cl-labels (bindings &rest body)
"Make temporary function bindings.
-This is like `cl-flet', except the bindings are lexical instead of dynamic.
-Unlike `cl-flet', this macro is fully compliant with the Common Lisp standard.
+The bindings can be recursive and the scoping is lexical, but capturing them
+in closures will only work if `lexical-binding' is in use.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug cl-flet))
- (let ((vars nil) (sets nil) (newenv macroexpand-all-environment))
- (while bindings
- ;; Use `cl-gensym' rather than `make-symbol'. It's important that
- ;; (not (eq (symbol-name var1) (symbol-name var2))) because these
- ;; vars get added to the cl-macro-environment.
- (let ((var (cl-gensym "--cl-var--")))
- (push var vars)
- (push `(cl-function (lambda . ,(cdar bindings))) sets)
- (push var sets)
- (push (cons (car (pop bindings))
+ (let ((binds ()) (newenv macroexpand-all-environment))
+ (dolist (binding bindings)
+ (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
+ (push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
+ (push (cons (car binding)
`(lambda (&rest cl-labels-args)
(cl-list* 'funcall ',var
cl-labels-args)))
newenv)))
- (macroexpand-all `(cl-lexical-let ,vars (setq ,@sets) ,@body) newenv)))
+ (macroexpand-all `(letrec ,(nreverse binds) ,@body)
+ ;; Don't override lexical-let's macro-expander.
+ (if (assq 'function newenv) newenv
+ (cons (cons 'function #'cl--labels-convert) newenv)))))
;; The following ought to have a better definition for use with newer
;; byte compilers.
cl--old-macroexpand
(symbol-function 'macroexpand)))
-(defun cl--sm-macroexpand (cl-macro &optional cl-env)
+(defun cl--sm-macroexpand (exp &optional env)
"Special macro expander used inside `cl-symbol-macrolet'.
This function replaces `macroexpand' during macro expansion
of `cl-symbol-macrolet', and does the same thing as `macroexpand'
except that it additionally expands symbol macros."
- (let ((macroexpand-all-environment cl-env))
+ (let ((macroexpand-all-environment env))
(while
(progn
- (setq cl-macro (funcall cl--old-macroexpand cl-macro cl-env))
- (cond
- ((symbolp cl-macro)
- ;; Perform symbol-macro expansion.
- (when (cdr (assq (symbol-name cl-macro) cl-env))
- (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))))
- ((eq 'setq (car-safe cl-macro))
- ;; Convert setq to cl-setf if required by symbol-macro expansion.
- (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f cl-env))
- (cdr cl-macro)))
- (p args))
- (while (and p (symbolp (car p))) (setq p (cddr p)))
- (if p (setq cl-macro (cons 'cl-setf args))
- (setq cl-macro (cons 'setq args))
- ;; Don't loop further.
- nil))))))
- cl-macro))
+ (setq exp (funcall cl--old-macroexpand exp env))
+ (pcase exp
+ ((pred symbolp)
+ ;; Perform symbol-macro expansion.
+ (when (cdr (assq (symbol-name exp) env))
+ (setq exp (cadr (assq (symbol-name exp) env)))))
+ (`(setq . ,_)
+ ;; Convert setq to setf if required by symbol-macro expansion.
+ (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env))
+ (cdr exp)))
+ (p args))
+ (while (and p (symbolp (car p))) (setq p (cddr p)))
+ (if p (setq exp (cons 'setf args))
+ (setq exp (cons 'setq args))
+ ;; Don't loop further.
+ nil)))
+ (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare))
+ ;; CL's symbol-macrolet treats re-bindings as candidates for
+ ;; expansion (turning the let into a letf if needed), contrary to
+ ;; Common-Lisp where such re-bindings hide the symbol-macro.
+ (let ((letf nil) (found nil) (nbs ()))
+ (dolist (binding bindings)
+ (let* ((var (if (symbolp binding) binding (car binding)))
+ (sm (assq (symbol-name var) env)))
+ (push (if (not (cdr sm))
+ binding
+ (let ((nexp (cadr sm)))
+ (setq found t)
+ (unless (symbolp nexp) (setq letf t))
+ (cons nexp (cdr-safe binding))))
+ nbs)))
+ (when found
+ (setq exp `(,(if letf
+ (if (eq (car exp) 'let) 'cl-letf 'cl-letf*)
+ (car exp))
+ ,(nreverse nbs)
+ ,@body)))))
+ ;; FIXME: The behavior of CL made sense in a dynamically scoped
+ ;; language, but for lexical scoping, Common-Lisp's behavior might
+ ;; make more sense (and indeed, CL behaves like Common-Lisp w.r.t
+ ;; lexical-let), so maybe we should adjust the behavior based on
+ ;; the use of lexical-binding.
+ ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare))
+ ;; (let ((nbs ()) (found nil))
+ ;; (dolist (binding bindings)
+ ;; (let* ((var (if (symbolp binding) binding (car binding)))
+ ;; (name (symbol-name var))
+ ;; (val (and found (consp binding) (eq 'let* (car exp))
+ ;; (list (macroexpand-all (cadr binding)
+ ;; env)))))
+ ;; (push (if (assq name env)
+ ;; ;; This binding should hide its symbol-macro,
+ ;; ;; but given the way macroexpand-all works, we
+ ;; ;; can't prevent application of `env' to the
+ ;; ;; sub-expressions, so we need to α-rename this
+ ;; ;; variable instead.
+ ;; (let ((nvar (make-symbol
+ ;; (copy-sequence name))))
+ ;; (setq found t)
+ ;; (push (list name nvar) env)
+ ;; (cons nvar (or val (cdr-safe binding))))
+ ;; (if val (cons var val) binding))
+ ;; nbs)))
+ ;; (when found
+ ;; (setq exp `(,(car exp)
+ ;; ,(nreverse nbs)
+ ;; ,@(macroexp-unprogn
+ ;; (macroexpand-all (macroexp-progn body)
+ ;; env)))))
+ ;; nil))
+ )))
+ exp))
;;;###autoload
(defmacro cl-symbol-macrolet (bindings &rest body)
"Make symbol macro definitions.
Within the body FORMs, references to the variable NAME will be replaced
-by EXPANSION, and (setq NAME ...) will act like (cl-setf EXPANSION ...).
+by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
\(fn ((NAME EXPANSION) ...) FORM...)"
(declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body)))
(cond
((cdr bindings)
- `(cl-symbol-macrolet (,(car bindings))
+ `(cl-symbol-macrolet (,(car bindings))
(cl-symbol-macrolet ,(cdr bindings) ,@body)))
((null bindings) (macroexp-progn body))
(t
(fset 'macroexpand #'cl--sm-macroexpand)
;; FIXME: For N bindings, this will traverse `body' N times!
(macroexpand-all (cons 'progn body)
- (cons (list (symbol-name (caar bindings))
- (cl-cadar bindings))
+ (cons (list (symbol-name (caar bindings))
+ (cl-cadar bindings))
macroexpand-all-environment)))
(fset 'macroexpand previous-macroexpand))))))
-(defvar cl-closure-vars nil)
-(defvar cl--function-convert-cache nil)
-
-(defun cl--function-convert (f)
- "Special macro-expander for special cases of (function F).
-The two cases that are handled are:
-- closure-conversion of lambda expressions for `cl-lexical-let'.
-- renaming of F when it's a function defined via `cl-labels'."
- (cond
- ;; ¡¡Big Ugly Hack!! We can't use a compiler-macro because those are checked
- ;; *after* handling `function', but we want to stop macroexpansion from
- ;; being applied infinitely, so we use a cache to return the exact `form'
- ;; being expanded even though we don't receive it.
- ((eq f (car cl--function-convert-cache)) (cdr cl--function-convert-cache))
- ((eq (car-safe f) 'lambda)
- (let ((body (mapcar (lambda (f)
- (macroexpand-all f macroexpand-all-environment))
- (cddr f))))
- (if (and cl-closure-vars
- (cl--expr-contains-any body cl-closure-vars))
- (let* ((new (mapcar 'cl-gensym cl-closure-vars))
- (sub (cl-pairlis cl-closure-vars new)) (decls nil))
- (while (or (stringp (car body))
- (eq (car-safe (car body)) 'interactive))
- (push (list 'quote (pop body)) decls))
- (put (car (last cl-closure-vars)) 'used t)
- `(list 'lambda '(&rest --cl-rest--)
- ,@(cl-sublis sub (nreverse decls))
- (list 'apply
- (list 'quote
- #'(lambda ,(append new (cadr f))
- ,@(cl-sublis sub body)))
- ,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
- cl-closure-vars)
- '((quote --cl-rest--))))))
- (let* ((newf `(lambda ,(cadr f) ,@body))
- (res `(function ,newf)))
- (setq cl--function-convert-cache (cons newf res))
- res))))
- (t
- (let ((found (assq f macroexpand-all-environment)))
- (if (and found (ignore-errors
- (eq (cadr (cl-caddr found)) 'cl-labels-args)))
- (cadr (cl-caddr (cl-cadddr found)))
- (let ((res `(function ,f)))
- (setq cl--function-convert-cache (cons f res))
- res))))))
-
-;;;###autoload
-(defmacro cl-lexical-let (bindings &rest body)
- "Like `let', but lexically scoped.
-The main visible difference is that lambdas inside BODY will create
-lexical closures as in Common Lisp.
-\n(fn BINDINGS BODY)"
- (declare (indent 1) (debug let))
- (let* ((cl-closure-vars cl-closure-vars)
- (vars (mapcar (function
- (lambda (x)
- (or (consp x) (setq x (list x)))
- (push (make-symbol (format "--cl-%s--" (car x)))
- cl-closure-vars)
- (set (car cl-closure-vars) [bad-lexical-ref])
- (list (car x) (cadr x) (car cl-closure-vars))))
- bindings))
- (ebody
- (macroexpand-all
- `(cl-symbol-macrolet
- ,(mapcar (lambda (x)
- `(,(car x) (symbol-value ,(cl-caddr x))))
- vars)
- ,@body)
- (cons (cons 'function #'cl--function-convert)
- macroexpand-all-environment))))
- (if (not (get (car (last cl-closure-vars)) 'used))
- ;; Turn (let ((foo (cl-gensym)))
- ;; (set foo <val>) ...(symbol-value foo)...)
- ;; into (let ((foo <val>)) ...(symbol-value 'foo)...).
- ;; This is good because it's more efficient but it only works with
- ;; dynamic scoping, since with lexical scoping we'd need
- ;; (let ((foo <val>)) ...foo...).
- `(progn
- ,@(mapcar (lambda (x) `(defvar ,(cl-caddr x))) vars)
- (let ,(mapcar (lambda (x) (list (cl-caddr x) (cadr x))) vars)
- ,(cl-sublis (mapcar (lambda (x)
- (cons (cl-caddr x)
- `',(cl-caddr x)))
- vars)
- ebody)))
- `(let ,(mapcar (lambda (x)
- (list (cl-caddr x)
- `(make-symbol ,(format "--%s--" (car x)))))
- vars)
- (cl-setf ,@(apply #'append
- (mapcar (lambda (x)
- (list `(symbol-value ,(cl-caddr x)) (cadr x)))
- vars)))
- ,ebody))))
-
-;;;###autoload
-(defmacro cl-lexical-let* (bindings &rest body)
- "Like `let*', but lexically scoped.
-The main visible difference is that lambdas inside BODY, and in
-successive bindings within BINDINGS, will create lexical closures
-as in Common Lisp. This is similar to the behavior of `let*' in
-Common Lisp.
-\n(fn BINDINGS BODY)"
- (declare (indent 1) (debug let))
- (if (null bindings) (cons 'progn body)
- (setq bindings (reverse bindings))
- (while bindings
- (setq body (list `(cl-lexical-let (,(pop bindings)) ,@body))))
- (car body)))
-
;;; Multiple values.
;;;###autoload
(declare (debug t))
(cons 'progn body))
;;;###autoload
-(defmacro cl-the (type form)
+(defmacro cl-the (_type form)
(declare (indent 1) (debug (cl-type-spec form)))
form)
will turn off byte-compile warnings in the function.
See Info node `(cl)Declarations' for details."
- (if (cl-compiling-file)
+ (if (cl--compiling-file)
(while specs
(if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
(cl-do-proclaim (pop specs) nil)))
-;;; Generalized variables.
-
-;;;###autoload
-(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
-going to be expanded as a macro, then the BODY forms are executed and must
-return a list of five elements: a temporary-variables list, a value-forms
-list, a store-variables list (of length one), a store-form, and an access-
-form. See `cl-defsetf' for a simpler way to define most setf-methods.
-
-\(fn NAME ARGLIST BODY...)"
- (declare (debug
- (&define name cl-lambda-list cl-declarations-or-string def-body)))
- `(cl-eval-when (compile load eval)
- ,@(if (stringp (car body))
- (list `(put ',func 'setf-documentation ,(pop body))))
- ,(cl--transform-function-property
- func 'setf-method (cons args body))))
-
-;;;###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-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:
-
- (cl-defsetf aref aset)
-
-Alternate form: (cl-defsetf NAME ARGLIST (STORE) BODY...).
-Here, the above `cl-setf' call is expanded by binding the argument forms ARGS
-according to ARGLIST, binding the value form VAL to STORE, then executing
-BODY, which must return a Lisp form that does the necessary `cl-setf' operation.
-Actually, ARGLIST and STORE may be bound to temporary variables which are
-introduced automatically to preserve proper execution order of the arguments.
-Example:
-
- (cl-defsetf nth (n x) (v) `(setcar (nthcdr ,n ,x) ,v))
-
-\(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
- (declare (debug
- (&define name
- [&or [symbolp &optional stringp]
- [cl-lambda-list (symbolp)]]
- cl-declarations-or-string def-body)))
- (if (and (listp arg1) (consp args))
- (let* ((largs nil) (largsr nil)
- (temps nil) (tempsr nil)
- (restarg nil) (rest-temps nil)
- (store-var (car (prog1 (car args) (setq args (cdr args)))))
- (store-temp (intern (format "--%s--temp--" store-var)))
- (lets1 nil) (lets2 nil)
- (docstr nil) (p arg1))
- (if (stringp (car args))
- (setq docstr (prog1 (car args) (setq args (cdr args)))))
- (while (and p (not (eq (car p) '&aux)))
- (if (eq (car p) '&rest)
- (setq p (cdr p) restarg (car p))
- (or (memq (car p) '(&optional &key &allow-other-keys))
- (setq largs (cons (if (consp (car p)) (car (car p)) (car p))
- largs)
- temps (cons (intern (format "--%s--temp--" (car largs)))
- temps))))
- (setq p (cdr p)))
- (setq largs (nreverse largs) temps (nreverse temps))
- (if restarg
- (setq largsr (append largs (list restarg))
- rest-temps (intern (format "--%s--temp--" restarg))
- tempsr (append temps (list rest-temps)))
- (setq largsr largs tempsr temps))
- (let ((p1 largs) (p2 temps))
- (while p1
- (setq lets1 (cons `(,(car p2)
- (make-symbol ,(format "--cl-%s--" (car p1))))
- lets1)
- 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-expander ,func ,arg1
- ,@(and docstr (list docstr))
- (let*
- ,(nreverse
- (cons `(,store-temp
- (make-symbol ,(format "--cl-%s--" store-var)))
- (if restarg
- `((,rest-temps
- (mapcar (lambda (_) (make-symbol "--cl-var--"))
- ,restarg))
- ,@lets1)
- lets1)))
- (list ; 'values
- (,(if restarg 'cl-list* 'list) ,@tempsr)
- (,(if restarg 'cl-list* 'list) ,@largsr)
- (list ,store-temp)
- (let*
- ,(nreverse
- (cons (list store-var store-temp)
- lets2))
- ,@args)
- (,(if restarg 'cl-list* 'list)
- ,@(cons `',func tempsr))))))
- `(cl-defsetf ,func (&rest args) (store)
- ,(let ((call `(cons ',arg1
- (append args (list store)))))
- (if (car args)
- `(list 'progn ,call store)
- call)))))
-
-;;; Some standard place types from Common Lisp.
-(cl-defsetf aref aset)
-(cl-defsetf car setcar)
-(cl-defsetf cdr setcdr)
-(cl-defsetf caar (x) (val) `(setcar (car ,x) ,val))
-(cl-defsetf cadr (x) (val) `(setcar (cdr ,x) ,val))
-(cl-defsetf cdar (x) (val) `(setcdr (car ,x) ,val))
-(cl-defsetf cddr (x) (val) `(setcdr (cdr ,x) ,val))
-(cl-defsetf elt (seq n) (store)
- `(if (listp ,seq) (setcar (nthcdr ,n ,seq) ,store)
- (aset ,seq ,n ,store)))
-(cl-defsetf get put)
-(cl-defsetf cl-get (x y &optional d) (store) `(put ,x ,y ,store))
-(cl-defsetf gethash (x h &optional d) (store) `(puthash ,x ,store ,h))
-(cl-defsetf nth (n x) (store) `(setcar (nthcdr ,n ,x) ,store))
-(cl-defsetf cl-subseq (seq start &optional end) (new)
- `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) ,new))
-(cl-defsetf symbol-function fset)
-(cl-defsetf symbol-plist setplist)
-(cl-defsetf symbol-value set)
-
-;;; Various car/cdr aliases. Note that `cadr' is handled specially.
-(cl-defsetf cl-first setcar)
-(cl-defsetf cl-second (x) (store) `(setcar (cdr ,x) ,store))
-(cl-defsetf cl-third (x) (store) `(setcar (cddr ,x) ,store))
-(cl-defsetf cl-fourth (x) (store) `(setcar (cl-cdddr ,x) ,store))
-(cl-defsetf cl-fifth (x) (store) `(setcar (nthcdr 4 ,x) ,store))
-(cl-defsetf cl-sixth (x) (store) `(setcar (nthcdr 5 ,x) ,store))
-(cl-defsetf cl-seventh (x) (store) `(setcar (nthcdr 6 ,x) ,store))
-(cl-defsetf cl-eighth (x) (store) `(setcar (nthcdr 7 ,x) ,store))
-(cl-defsetf cl-ninth (x) (store) `(setcar (nthcdr 8 ,x) ,store))
-(cl-defsetf cl-tenth (x) (store) `(setcar (nthcdr 9 ,x) ,store))
-(cl-defsetf cl-rest setcdr)
-
-;;; Some more Emacs-related place types.
-(cl-defsetf buffer-file-name set-visited-file-name t)
-(cl-defsetf buffer-modified-p (&optional buf) (flag)
- `(with-current-buffer ,buf
- (set-buffer-modified-p ,flag)))
-(cl-defsetf buffer-name rename-buffer t)
-(cl-defsetf buffer-string () (store)
- `(progn (erase-buffer) (insert ,store)))
-(cl-defsetf buffer-substring cl-set-buffer-substring)
-(cl-defsetf current-buffer set-buffer)
-(cl-defsetf current-case-table set-case-table)
-(cl-defsetf current-column move-to-column t)
-(cl-defsetf current-global-map use-global-map t)
-(cl-defsetf current-input-mode () (store)
- `(progn (apply #'set-input-mode ,store) ,store))
-(cl-defsetf current-local-map use-local-map t)
-(cl-defsetf current-window-configuration set-window-configuration t)
-(cl-defsetf default-file-modes set-default-file-modes t)
-(cl-defsetf default-value set-default)
-(cl-defsetf documentation-property put)
-(cl-defsetf face-background (f &optional s) (x) `(set-face-background ,f ,x ,s))
-(cl-defsetf face-background-pixmap (f &optional s) (x)
- `(set-face-background-pixmap ,f ,x ,s))
-(cl-defsetf face-font (f &optional s) (x) `(set-face-font ,f ,x ,s))
-(cl-defsetf face-foreground (f &optional s) (x) `(set-face-foreground ,f ,x ,s))
-(cl-defsetf face-underline-p (f &optional s) (x)
- `(set-face-underline-p ,f ,x ,s))
-(cl-defsetf file-modes set-file-modes t)
-(cl-defsetf frame-height set-screen-height t)
-(cl-defsetf frame-parameters modify-frame-parameters t)
-(cl-defsetf frame-visible-p cl-set-frame-visible-p)
-(cl-defsetf frame-width set-screen-width t)
-(cl-defsetf frame-parameter set-frame-parameter t)
-(cl-defsetf terminal-parameter set-terminal-parameter)
-(cl-defsetf getenv setenv t)
-(cl-defsetf get-register set-register)
-(cl-defsetf global-key-binding global-set-key)
-(cl-defsetf keymap-parent set-keymap-parent)
-(cl-defsetf local-key-binding local-set-key)
-(cl-defsetf mark set-mark t)
-(cl-defsetf mark-marker set-mark t)
-(cl-defsetf marker-position set-marker t)
-(cl-defsetf match-data set-match-data t)
-(cl-defsetf mouse-position (scr) (store)
- `(set-mouse-position ,scr (car ,store) (cadr ,store)
- (cddr ,store)))
-(cl-defsetf overlay-get overlay-put)
-(cl-defsetf overlay-start (ov) (store)
- `(progn (move-overlay ,ov ,store (overlay-end ,ov)) ,store))
-(cl-defsetf overlay-end (ov) (store)
- `(progn (move-overlay ,ov (overlay-start ,ov) ,store) ,store))
-(cl-defsetf point goto-char)
-(cl-defsetf point-marker goto-char t)
-(cl-defsetf point-max () (store)
- `(progn (narrow-to-region (point-min) ,store) ,store))
-(cl-defsetf point-min () (store)
- `(progn (narrow-to-region ,store (point-max)) ,store))
-(cl-defsetf process-buffer set-process-buffer)
-(cl-defsetf process-filter set-process-filter)
-(cl-defsetf process-sentinel set-process-sentinel)
-(cl-defsetf process-get process-put)
-(cl-defsetf read-mouse-position (scr) (store)
- `(set-mouse-position ,scr (car ,store) (cdr ,store)))
-(cl-defsetf screen-height set-screen-height t)
-(cl-defsetf screen-width set-screen-width t)
-(cl-defsetf selected-window select-window)
-(cl-defsetf selected-screen select-screen)
-(cl-defsetf selected-frame select-frame)
-(cl-defsetf standard-case-table set-standard-case-table)
-(cl-defsetf syntax-table set-syntax-table)
-(cl-defsetf visited-file-modtime set-visited-file-modtime t)
-(cl-defsetf window-buffer set-window-buffer t)
-(cl-defsetf window-display-table set-window-display-table t)
-(cl-defsetf window-dedicated-p set-window-dedicated-p t)
-(cl-defsetf window-height () (store)
- `(progn (enlarge-window (- ,store (window-height))) ,store))
-(cl-defsetf window-hscroll set-window-hscroll)
-(cl-defsetf window-parameter set-window-parameter)
-(cl-defsetf window-point set-window-point)
-(cl-defsetf window-start set-window-start)
-(cl-defsetf window-width () (store)
- `(progn (enlarge-window (- ,store (window-width)) t) ,store))
-(cl-defsetf x-get-secondary-selection x-own-secondary-selection t)
-(cl-defsetf x-get-selection x-own-selection t)
-
-;; This is a hack that allows (cl-setf (eq a 7) B) to mean either
-;; (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-expander eq (place val)
- (let ((method (cl-get-setf-method place macroexpand-all-environment))
- (val-temp (make-symbol "--eq-val--"))
- (store-temp (make-symbol "--eq-store--")))
- (list (append (nth 0 method) (list val-temp))
- (append (nth 1 method) (list val))
- (list store-temp)
- `(let ((,(car (nth 2 method))
- (if ,store-temp ,val-temp (not ,val-temp))))
- ,(nth 3 method) ,store-temp)
- `(eq ,(nth 4 method) ,val-temp))))
-
-;;; More complex setf-methods.
-;; These should take &environment arguments, but since full arglists aren't
-;; available while compiling cl-macs, we fake it by referring to the global
-;; variable macroexpand-all-environment directly.
-
-(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))
- (let* ((form (cons (nth 1 func) (cons arg1 rest)))
- (method (cl-get-setf-method form macroexpand-all-environment)))
- (list (car method) (nth 1 method) (nth 2 method)
- (cl-setf-make-apply (nth 3 method) (cadr func) (car method))
- (cl-setf-make-apply (nth 4 method) (cadr func) (car method)))))
-
-(defun cl-setf-make-apply (form func temps)
- (if (eq (car form) 'progn)
- `(progn ,(cl-setf-make-apply (cadr form) func temps) ,@(cddr form))
- (or (equal (last form) (last temps))
- (error "%s is not suitable for use with setf-of-apply" func))
- `(apply ',(car form) ,@(cdr form))))
-
-(cl-define-setf-expander nthcdr (n place)
- (let ((method (cl-get-setf-method place macroexpand-all-environment))
- (n-temp (make-symbol "--cl-nthcdr-n--"))
- (store-temp (make-symbol "--cl-nthcdr-store--")))
- (list (cons n-temp (car method))
- (cons n (nth 1 method))
- (list store-temp)
- `(let ((,(car (nth 2 method))
- (cl-set-nthcdr ,n-temp ,(nth 4 method)
- ,store-temp)))
- ,(nth 3 method) ,store-temp)
- `(nthcdr ,n-temp ,(nth 4 method)))))
-
-(cl-define-setf-expander cl-getf (place tag &optional def)
- (let ((method (cl-get-setf-method place macroexpand-all-environment))
- (tag-temp (make-symbol "--cl-getf-tag--"))
- (def-temp (make-symbol "--cl-getf-def--"))
- (store-temp (make-symbol "--cl-getf-store--")))
- (list (append (car method) (list tag-temp def-temp))
- (append (nth 1 method) (list tag def))
- (list store-temp)
- `(let ((,(car (nth 2 method))
- (cl-set-getf ,(nth 4 method) ,tag-temp ,store-temp)))
- ,(nth 3 method) ,store-temp)
- `(cl-getf ,(nth 4 method) ,tag-temp ,def-temp))))
-
-(cl-define-setf-expander substring (place from &optional to)
- (let ((method (cl-get-setf-method place macroexpand-all-environment))
- (from-temp (make-symbol "--cl-substring-from--"))
- (to-temp (make-symbol "--cl-substring-to--"))
- (store-temp (make-symbol "--cl-substring-store--")))
- (list (append (car method) (list from-temp to-temp))
- (append (nth 1 method) (list from to))
- (list store-temp)
- `(let ((,(car (nth 2 method))
- (cl-set-substring ,(nth 4 method)
- ,from-temp ,to-temp ,store-temp)))
- ,(nth 3 method) ,store-temp)
- `(substring ,(nth 4 method) ,from-temp ,to-temp))))
-
-;;; Getting and optimizing setf-methods.
-;;;###autoload
-(defun cl-get-setf-method (place &optional env)
- "Return a list of five values describing the setf-method for PLACE.
-PLACE may be any Lisp form which can appear as the PLACE argument to
-a macro like `cl-setf' or `cl-incf'."
- (if (symbolp place)
- (let ((temp (make-symbol "--cl-setf--")))
- (list nil nil (list temp) `(setq ,place ,temp) place))
- (or (and (symbolp (car place))
- (let* ((func (car place))
- (name (symbol-name func))
- (method (get func 'setf-method))
- (case-fold-search nil))
- (or (and method
- (let ((macroexpand-all-environment env))
- (setq method (apply method (cdr place))))
- (if (and (consp method) (= (length method) 5))
- method
- (error "Setf-method for %s returns malformed method"
- func)))
- (and (string-match-p "\\`c[ad][ad][ad]?[ad]?r\\'" name)
- (cl-get-setf-method (cl-compiler-macroexpand place)))
- (and (eq func 'edebug-after)
- (cl-get-setf-method (nth (1- (length place)) place)
- env)))))
- (if (eq place (setq place (macroexpand place env)))
- (if (and (symbolp (car place)) (fboundp (car place))
- (symbolp (symbol-function (car place))))
- (cl-get-setf-method (cons (symbol-function (car place))
- (cdr place)) env)
- (error "No setf-method known for %s" (car place)))
- (cl-get-setf-method place env)))))
-
-(defun cl-setf-do-modify (place opt-expr)
- (let* ((method (cl-get-setf-method place macroexpand-all-environment))
- (temps (car method)) (values (nth 1 method))
- (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-setf-simple-store-p (car (nth 2 method))
- (nth 3 method)))))
- (simple (and optimize (consp place) (cl--simple-exprs-p (cdr place)))))
- (while 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)
- (cons (car (nth 2 method)) (cl-sublis subs (nth 3 method)))
- (cl-sublis subs (nth 4 method)))))
-
-(defun cl-setf-do-store (spec val)
- (let ((sym (car spec))
- (form (cdr spec)))
- (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)
- (eq (nth (1- (length form)) form) sym)
- (symbolp (car form)) (fboundp (car form))
- (not (eq (car-safe (symbol-function (car form))) 'macro))))
-
;;; The standard modify macros.
-;;;###autoload
-(defmacro cl-setf (&rest args)
- "Set each PLACE to the value of its VAL.
-This is a generalized version of `setq'; the PLACEs may be symbolic
-references such as (car x) or (aref x i), as well as plain symbols.
-For example, (cl-setf (cl-cadar x) y) is equivalent to (setcar (cdar x) y).
-The return value is the last VAL in the list.
-\(fn PLACE VAL PLACE VAL ...)"
- (declare (debug (&rest [place form])))
- (if (cdr (cdr args))
- (let ((sets nil))
- (while args (push `(cl-setf ,(pop args) ,(pop args)) sets))
- (cons 'progn (nreverse sets)))
- (if (symbolp (car args))
- (and args (cons 'setq args))
- (let* ((method (cl-setf-do-modify (car args) (nth 1 args)))
- (store (cl-setf-do-store (nth 1 method) (nth 1 args))))
- (if (car method) `(let* ,(car method) ,store) store)))))
+;; `setf' is now part of core Elisp, defined in gv.el.
;;;###autoload
(defmacro cl-psetf (&rest args)
"Set PLACEs to the values VALs in parallel.
-This is like `cl-setf', except that all VAL forms are evaluated (in order)
+This is like `setf', except that all VAL forms are evaluated (in order)
before assigning any PLACEs to the corresponding values.
\(fn PLACE VAL PLACE VAL ...)"
- (declare (debug cl-setf))
+ (declare (debug setf))
(let ((p args) (simple t) (vars nil))
(while p
(if (or (not (symbolp (car p))) (cl--expr-depends-p (nth 1 p) vars))
(or p (error "Odd number of arguments to cl-psetf"))
(pop p))
(if simple
- `(progn (cl-setf ,@args) nil)
+ `(progn (setf ,@args) nil)
(setq args (reverse args))
- (let ((expr `(cl-setf ,(cadr args) ,(car args))))
+ (let ((expr `(setf ,(cadr args) ,(car args))))
(while (setq args (cddr args))
- (setq expr `(cl-setf ,(cadr args) (prog1 ,(car args) ,expr))))
+ (setq expr `(setf ,(cadr args) (prog1 ,(car args) ,expr))))
`(progn ,expr nil)))))
-;;;###autoload
-(defun cl-do-pop (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--")))
- `(let* (,@(car method)
- (,temp ,(nth 2 method)))
- (prog1 (car ,temp)
- ,(cl-setf-do-store (nth 1 method) `(cdr ,temp)))))))
-
;;;###autoload
(defmacro cl-remf (place tag)
"Remove TAG from property list PLACE.
-PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
+PLACE may be a symbol, or any generalized variable allowed by `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 (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))))
- `(let* (,@(car method)
- ,@(and val-temp `((,val-temp ,(nth 2 method))))
- ,@(and tag-temp `((,tag-temp ,tag))))
- (if (eq ,ttag (car ,tval))
- (progn ,(cl-setf-do-store (nth 1 method) `(cddr ,tval))
+ (gv-letplace (tval setter) place
+ (macroexp-let2 macroexp-copyable-p ttag tag
+ `(if (eq ,ttag (car ,tval))
+ (progn ,(funcall setter `(cddr ,tval))
t)
- `(cl-do-remf ,tval ,ttag)))))
+ (cl--do-remf ,tval ,ttag)))))
;;;###autoload
(defmacro cl-shiftf (place &rest args)
"Shift left among PLACEs.
Example: (cl-shiftf A B C) sets A to B, B to C, and returns the old A.
-Each PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
+Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
\(fn PLACE... VAL)"
(declare (debug (&rest place)))
((null args) place)
((symbolp place) `(prog1 ,place (setq ,place (cl-shiftf ,@args))))
(t
- (let ((method (cl-setf-do-modify place 'unsafe)))
- `(let* ,(car method)
- (prog1 ,(nth 2 method)
- ,(cl-setf-do-store (nth 1 method) `(cl-shiftf ,@args))))))))
+ (gv-letplace (getter setter) place
+ `(prog1 ,getter
+ ,(funcall setter `(cl-shiftf ,@args)))))))
;;;###autoload
(defmacro cl-rotatef (&rest args)
"Rotate left among PLACEs.
Example: (cl-rotatef A B C) sets A to B, B to C, and C to A. It returns nil.
-Each PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
+Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
\(fn PLACE...)"
(declare (debug (&rest place)))
(temp (make-symbol "--cl-rotatef--"))
(form temp))
(while (cdr places)
- (let ((method (cl-setf-do-modify (pop places) 'unsafe)))
- (setq form `(let* ,(car method)
- (prog1 ,(nth 2 method)
- ,(cl-setf-do-store (nth 1 method) form))))))
- (let ((method (cl-setf-do-modify (car places) 'unsafe)))
- `(let* (,@(car method) (,temp ,(nth 2 method)))
- ,(cl-setf-do-store (nth 1 method) form) nil)))))
+ (setq form
+ (gv-letplace (getter setter) (pop places)
+ `(prog1 ,getter ,(funcall setter form)))))
+ (gv-letplace (getter setter) (car places)
+ (macroexp-let* `((,temp ,getter))
+ `(progn ,(funcall setter form) nil))))))
+
+;; FIXME: `letf' is unsatisfactory because it does not really "restore" the
+;; previous state. If the getter/setter loses information, that info is
+;; not recovered.
+
+(defun cl--letf (bindings simplebinds binds body)
+ ;; It's not quite clear what the semantics of cl-letf should be.
+ ;; E.g. in (cl-letf ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear
+ ;; that the actual assignments ("bindings") should only happen after
+ ;; evaluating VAL1 and VAL2, it's not clear when the sub-expressions of
+ ;; PLACE1 and PLACE2 should be evaluated. Should we have
+ ;; PLACE1; VAL1; PLACE2; VAL2; bind1; bind2
+ ;; or
+ ;; VAL1; VAL2; PLACE1; PLACE2; bind1; bind2
+ ;; or
+ ;; VAL1; VAL2; PLACE1; bind1; PLACE2; bind2
+ ;; Common-Lisp's `psetf' does the first, so we'll do the same.
+ (if (null bindings)
+ (if (and (null binds) (null simplebinds)) (macroexp-progn body)
+ `(let* (,@(mapcar (lambda (x)
+ (pcase-let ((`(,vold ,getter ,_setter ,_vnew) x))
+ (list vold getter)))
+ binds)
+ ,@simplebinds)
+ (unwind-protect
+ ,(macroexp-progn
+ (append
+ (delq nil
+ (mapcar (lambda (x)
+ (pcase x
+ ;; If there's no vnew, do nothing.
+ (`(,_vold ,_getter ,setter ,vnew)
+ (funcall setter vnew))))
+ binds))
+ body))
+ ,@(mapcar (lambda (x)
+ (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x))
+ (funcall setter vold)))
+ binds))))
+ (let ((binding (car bindings)))
+ (gv-letplace (getter setter) (car binding)
+ (macroexp-let2 nil vnew (cadr binding)
+ (if (symbolp (car binding))
+ ;; Special-case for simple variables.
+ (cl--letf (cdr bindings)
+ (cons `(,getter ,(if (cdr binding) vnew getter))
+ simplebinds)
+ binds body)
+ (cl--letf (cdr bindings) simplebinds
+ (cons `(,(make-symbol "old") ,getter ,setter
+ ,@(if (cdr binding) (list vnew)))
+ binds)
+ body)))))))
;;;###autoload
(defmacro cl-letf (bindings &rest body)
"Temporarily bind to PLACEs.
This is the analogue of `let', but with generalized variables (in the
-sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding
+sense of `setf') for the PLACEs. Each PLACE is set to the corresponding
VALUE, then the BODY forms are executed. On exit, either normally or
because of a `throw' or error, the PLACEs are set back to their original
values. Note that this macro is *not* available in Common Lisp.
the PLACE is not modified before executing BODY.
\(fn ((PLACE VALUE) ...) BODY...)"
- (declare (indent 1) (debug ((&rest (gate place &optional form)) body)))
+ (declare (indent 1) (debug ((&rest (gate gv-place &optional form)) body)))
(if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
`(let ,bindings ,@body)
- (let ((lets nil) (sets nil)
- (unsets nil) (rev (reverse bindings)))
- (while rev
- (let* ((place (if (symbolp (caar rev))
- `(symbol-value ',(caar rev))
- (caar rev)))
- (value (cl-cadar rev))
- (method (cl-setf-do-modify place 'no-opt))
- (save (make-symbol "--cl-letf-save--"))
- (bound (and (memq (car place) '(symbol-value symbol-function))
- (make-symbol "--cl-letf-bound--")))
- (temp (and (not (macroexp-const-p value)) (cdr bindings)
- (make-symbol "--cl-letf-val--"))))
- (setq lets (nconc (car method)
- (if bound
- (list (list bound
- (list (if (eq (car place)
- 'symbol-value)
- 'boundp 'fboundp)
- (nth 1 (nth 2 method))))
- (list save `(and ,bound
- ,(nth 2 method))))
- (list (list save (nth 2 method))))
- (and temp (list (list temp value)))
- lets)
- body (list
- `(unwind-protect
- (progn
- ,@(if (cdr (car rev))
- (cons (cl-setf-do-store (nth 1 method)
- (or temp value))
- body)
- body))
- ,(if bound
- `(if ,bound
- ,(cl-setf-do-store (nth 1 method) save)
- (,(if (eq (car place) 'symbol-value)
- #'makunbound #'fmakunbound)
- ,(nth 1 (nth 2 method))))
- (cl-setf-do-store (nth 1 method) save))))
- rev (cdr rev))))
- `(let* ,lets ,@body))))
-
+ (cl--letf bindings () () body)))
;;;###autoload
(defmacro cl-letf* (bindings &rest body)
"Temporarily bind to PLACEs.
-This is the analogue of `let*', but with generalized variables (in the
-sense of `cl-setf') for the PLACEs. Each PLACE is set to the corresponding
-VALUE, then the BODY forms are executed. On exit, either normally or
-because of a `throw' or error, the PLACEs are set back to their original
-values. Note that this macro is *not* available in Common Lisp.
-As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
-the PLACE is not modified before executing BODY.
-
-\(fn ((PLACE VALUE) ...) BODY...)"
+Like `cl-letf' but where the bindings are performed one at a time,
+rather than all at the end (i.e. like `let*' rather than like `let')."
(declare (indent 1) (debug cl-letf))
- (if (null bindings)
- (cons 'progn body)
- (setq bindings (reverse bindings))
- (while bindings
- (setq body (list `(cl-letf (,(pop bindings)) ,@body))))
- (car body)))
+ (dolist (binding (reverse bindings))
+ (setq body (list `(cl-letf (,binding) ,@body))))
+ (macroexp-progn body))
;;;###autoload
(defmacro cl-callf (func place &rest args)
"Set PLACE to (FUNC PLACE ARGS...).
FUNC should be an unquoted function name. PLACE may be a symbol,
-or any generalized variable allowed by `cl-setf'.
-
-\(fn FUNC PLACE ARGS...)"
+or any generalized variable allowed by `setf'."
(declare (indent 2) (debug (cl-function place &rest form)))
- (let* ((method (cl-setf-do-modify place (cons 'list args)))
- (rargs (cons (nth 2 method) args)))
- `(let* ,(car method)
- ,(cl-setf-do-store (nth 1 method)
- (if (symbolp func) (cons func rargs)
- `(funcall #',func ,@rargs))))))
+ (gv-letplace (getter setter) place
+ (let* ((rargs (cons getter args)))
+ (funcall setter
+ (if (symbolp func) (cons func rargs)
+ `(funcall #',func ,@rargs))))))
;;;###autoload
(defmacro cl-callf2 (func arg1 place &rest args)
\(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))
- `(cl-setf ,place (,func ,arg1 ,place ,@args))
- (let* ((method (cl-setf-do-modify place (cons 'list args)))
- (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)
- (if (symbolp func) (cons func rargs)
- `(funcall #',func ,@rargs)))))))
-
-;;;###autoload
-(defmacro cl-define-modify-macro (name arglist func &optional doc)
- "Define a `cl-setf'-like modify macro.
-If NAME is called, it combines its PLACE argument with the other arguments
-from ARGLIST using FUNC: (cl-define-modify-macro cl-incf (&optional (n 1)) +)"
- (declare (debug
- (&define name cl-lambda-list ;; should exclude &key
- symbolp &optional stringp)))
- (if (memq '&key arglist) (error "&key not allowed in cl-define-modify-macro"))
- (let ((place (make-symbol "--cl-place--")))
- `(cl-defmacro ,name (,place ,@arglist)
- ,doc
- (,(if (memq '&rest arglist) #'cl-list* #'list)
- #'cl-callf ',func ,place
- ,@(cl--arglist-args arglist)))))
-
+ `(setf ,place (,func ,arg1 ,place ,@args))
+ (macroexp-let2 nil a1 arg1
+ (gv-letplace (getter setter) place
+ (let* ((rargs (cl-list* a1 getter args)))
+ (funcall setter
+ (if (symbolp func) (cons func rargs)
+ `(funcall #',func ,@rargs))))))))
;;; Structures.
This macro defines a new data type called NAME that stores data
in SLOTs. It defines a `make-NAME' constructor, a `copy-NAME'
copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'.
-You can use the accessors to set the corresponding slots, via `cl-setf'.
+You can use the accessors to set the corresponding slots, via `setf'.
NAME may instead take the form (NAME OPTIONS...), where each
OPTION is either a single keyword or (KEYWORD VALUE).
Each SLOT may instead take the form (SLOT SLOT-OPTS...), where
SLOT-OPTS are keyword-value pairs for that slot. Currently, only
one keyword is supported, `:read-only'. If this has a non-nil
-value, that slot cannot be set via `cl-setf'.
+value, that slot cannot be set via `setf'.
\(fn NAME SLOTS...)"
(declare (doc-string 2)
(copier (intern (format "copy-%s" name)))
(predicate (intern (format "%s-p" name)))
(print-func nil) (print-auto nil)
- (safety (if (cl-compiling-file) cl-optimize-safety 3))
+ (safety (if (cl--compiling-file) cl-optimize-safety 3))
(include nil)
(tag (intern (format "cl-struct-%s" name)))
(tag-symbol (intern (format "cl-struct-%s-tags" name)))
(let ((accessor (intern (format "%s%s" conc-name slot))))
(push slot slots)
(push (nth 1 desc) defaults)
- (push (cl-list*
- 'cl-defsubst accessor '(cl-x)
- (append
- (and pred-check
+ (push `(cl-defsubst ,accessor (cl-x)
+ ,@(and pred-check
(list `(or ,pred-check
(error "%s accessing a non-%s"
',accessor ',name))))
- (list (if (eq type 'vector) `(aref cl-x ,pos)
- (if (= pos 0) '(car cl-x)
- `(nth ,pos cl-x)))))) forms)
+ ,(if (eq type 'vector) `(aref cl-x ,pos)
+ (if (= pos 0) '(car cl-x)
+ `(nth ,pos cl-x)))) forms)
(push (cons accessor t) side-eff)
- (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"
- ',accessor))
- ;; If cl is loaded only for compilation,
- ;; the call to cl-struct-setf-expander would
- ;; cause a warning because it may not be
- ;; defined at run time. Suppress that warning.
- `(progn
- (declare-function
- cl-struct-setf-expander "cl-macs"
- (x name accessor pred-form pos))
- (cl-struct-setf-expander
- cl-x ',name ',accessor
- ,(and pred-check `',pred-check)
- ,pos))))
- forms)
+ ;; Don't bother defining a setf-expander, since gv-get can use
+ ;; the compiler macro to get the same result.
+ ;;(push `(gv-define-setter ,accessor (cl-val cl-x)
+ ;; ,(if (cadr (memq :read-only (cddr desc)))
+ ;; `(progn (ignore cl-x cl-val)
+ ;; (error "%s is a read-only slot"
+ ;; ',accessor))
+ ;; ;; If cl is loaded only for compilation,
+ ;; ;; the call to cl--struct-setf-expander would
+ ;; ;; cause a warning because it may not be
+ ;; ;; defined at run time. Suppress that warning.
+ ;; `(progn
+ ;; (declare-function
+ ;; cl--struct-setf-expander "cl-macs"
+ ;; (x name accessor pred-form pos))
+ ;; (cl--struct-setf-expander
+ ;; cl-val cl-x ',name ',accessor
+ ;; ,(and pred-check `',pred-check)
+ ;; ,pos))))
+ ;; forms)
(if print-auto
(nconc print-func
(list `(princ ,(format " %s" slot) cl-s)
(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
- (push `(push
- ;; The auto-generated function does not pay attention to
- ;; the depth argument cl-n.
- (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n))
- (and ,pred-form ,print-func))
- cl-custom-print-functions)
- forms))
+ ;; Don't bother adding to cl-custom-print-functions since it's not used
+ ;; by anything anyway!
+ ;;(if print-func
+ ;; (push `(if (boundp 'cl-custom-print-functions)
+ ;; (push
+ ;; ;; The auto-generated function does not pay attention to
+ ;; ;; the depth argument cl-n.
+ ;; (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n))
+ ;; (and ,pred-form ,print-func))
+ ;; cl-custom-print-functions))
+ ;; forms))
(push `(setq ,tag-symbol (list ',tag)) forms)
(push `(cl-eval-when (compile load eval)
(put ',name 'cl-struct-slots ',descs)
forms)
`(progn ,@(nreverse (cons `',name forms)))))
-;;;###autoload
-(defun cl-struct-setf-expander (x name accessor pred-form pos)
- (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
- (list (list temp) (list x) (list store)
- `(progn
- ,@(and pred-form
- (list `(or ,(cl-subst temp 'cl-x pred-form)
- (error ,(format
- "%s storing a non-%s"
- accessor name)))))
- ,(if (eq (car (get name 'cl-struct-type)) 'vector)
- `(aset ,temp ,pos ,store)
- `(setcar
- ,(if (<= pos 5)
- (let ((xx temp))
- (while (>= (setq pos (1- pos)) 0)
- (setq xx `(cdr ,xx)))
- xx)
- `(nthcdr ,pos ,temp))
- ,store)))
- (list accessor temp))))
-
-
;;; Types and assertions.
;;;###autoload
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
- name 'cl-deftype-handler (cons `(&cl-defs '('*) ,@arglist) body))))
+ (put ',name 'cl-deftype-handler
+ (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body)))))
(defun cl--make-type-test (val type)
(if (symbolp type)
((eq (car type) 'satisfies) (list (cadr type) val))
(t (error "Bad type spec: %s" type)))))
+(defvar cl--object)
;;;###autoload
(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)))
+ (let ((cl--object object)) ;; Yuck!!
+ (eval (cl--make-type-test 'cl--object type))))
;;;###autoload
(defmacro cl-check-type (form type &optional string)
"Verify that FORM is of type TYPE; signal an error if not.
STRING is an optional description of the desired type."
(declare (debug (place cl-type-spec &optional stringp)))
- (and (or (not (cl-compiling-file))
+ (and (or (not (cl--compiling-file))
(< cl-optimize-speed 3) (= cl-optimize-safety 3))
(let* ((temp (if (cl--simple-expr-p form 3)
form (make-symbol "--cl-var--")))
;;;###autoload
(defmacro cl-assert (form &optional show-args string &rest args)
+ ;; FIXME: This is actually not compatible with Common-Lisp's `assert'.
"Verify that FORM returns non-nil; signal an error if not.
Second arg SHOW-ARGS means to include arguments of FORM in message.
Other args STRING and ARGS... are arguments to be passed to `error'.
They are not evaluated unless the assertion fails. If STRING is
omitted, a default message listing FORM itself is used."
(declare (debug (form &rest form)))
- (and (or (not (cl-compiling-file))
+ (and (or (not (cl--compiling-file))
(< cl-optimize-speed 3) (= cl-optimize-safety 3))
(let ((sargs (and show-args
(delq nil (mapcar (lambda (x)
(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
- func 'compiler-macro
- (cons (if (memq '&whole args) (delq '&whole args)
- (cons '_cl-whole-arg args)) body))
+ (put ',func 'compiler-macro
+ (cl-function (lambda ,(if (memq '&whole args) (delq '&whole args)
+ (cons '_cl-whole-arg args))
+ ,@body)))
;; This is so that describe-function can locate
;; the macro definition.
(let ((file ,(or buffer-file-name
(while (and (symbolp func)
(not (setq handler (get func 'compiler-macro)))
(fboundp func)
- (or (not (eq (car-safe (symbol-function func)) 'autoload))
- (load (nth 1 (symbol-function func)))))
+ (or (not (autoloadp (symbol-function func)))
+ (autoload-do-load (symbol-function func) func)))
(setq func (symbol-function func)))
(and handler
(not (eq form (setq form (apply handler form (cdr form))))))))
(defvar cl--active-block-names nil)
-(cl-define-compiler-macro cl-block-wrapper (cl-form)
+(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-body (macroexpand-all ;Performs compiler-macro expansions.
`(catch ,(nth 1 cl-form) ,@(cdr cl-body))
cl-body)))
-(cl-define-compiler-macro cl-block-throw (cl-tag cl-value)
+(cl-define-compiler-macro cl--block-throw (cl-tag cl-value)
(let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names)))
(if cl-found (setcdr cl-found t)))
`(throw ,cl-tag ,cl-value))
surrounded by (cl-block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
- (declare (debug cl-defun))
+ (declare (debug cl-defun) (indent 2))
(let* ((argns (cl--arglist-args args)) (p argns)
(pbody (cons 'progn body))
(unsafe (not (cl--safe-expr-p pbody))))
,(if (memq '&key args)
`(&whole cl-whole &cl-quote ,@args)
(cons '&cl-quote args))
- (cl-defsubst-expand
+ (cl--defsubst-expand
',argns '(cl-block ,name ,@body)
;; We used to pass `simple' as
;; (not (or unsafe (cl-expr-access-order pbody argns)))
,(and (memq '&key args) 'cl-whole) ,unsafe ,@argns)))
(cl-defun ,name ,args ,@body))))
-(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
+(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))
(let* ((substs ())
;; Compile-time optimizations for some functions defined in this package.
-;; Note that cl.el arranges to force cl-macs to be loaded at compile-time,
-;; mainly to make sure these macros will be present.
-
-(put 'eql 'byte-compile nil)
-(cl-define-compiler-macro eql (&whole form a b)
- (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))))
- ((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)
- `(if (numberp ,a)
- (equal ,a ,b)
- (eq ,a ,b)))
- ((and (cl--safe-expr-p a)
- (cl--simple-expr-p b 5))
- `(if (numberp ,b)
- (equal ,a ,b)
- (eq ,a ,b)))
- (t form)))
-
-(cl-define-compiler-macro cl-member (&whole form a list &rest keys)
+
+(defun cl--compiler-macro-member (form a list &rest keys)
(let ((test (and (= (length keys) 2) (eq (car keys) :test)
(cl--const-expr-val (nth 1 keys)))))
(cond ((eq test 'eq) `(memq ,a ,list))
((or (null keys) (eq test 'eql)) `(memql ,a ,list))
(t form))))
-(cl-define-compiler-macro cl-assoc (&whole form a list &rest keys)
+(defun cl--compiler-macro-assoc (form a list &rest keys)
(let ((test (and (= (length keys) 2) (eq (car keys) :test)
(cl--const-expr-val (nth 1 keys)))))
(cond ((eq test 'eq) `(assq ,a ,list))
`(assoc ,a ,list) `(assq ,a ,list)))
(t form))))
-(cl-define-compiler-macro cl-adjoin (&whole form a list &rest keys)
+;;;###autoload
+(defun cl--compiler-macro-adjoin (form a list &rest keys)
(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))
-(cl-define-compiler-macro cl-list* (arg &rest others)
+;;;###autoload
+(defun cl--compiler-macro-list* (_form arg &rest others)
(let* ((args (reverse (cons arg others)))
(form (car args)))
(while (setq args (cdr args))
(setq form `(cons ,(car args) ,form)))
form))
-(cl-define-compiler-macro cl-get (sym prop &optional def)
+(defun cl--compiler-macro-get (_form sym prop &optional def)
(if def
`(cl-getf (symbol-plist ,sym) ,prop ,def)
`(get ,sym ,prop)))
(cl-define-compiler-macro cl-typep (&whole form val type)
(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)))))
+ (macroexp-let2 macroexp-copyable-p temp val
+ (cl--make-type-test temp (cl--const-expr-val type)))
form))
-
-(mapc (lambda (y)
- (put (car y) 'side-effect-free t)
- (put (car y) 'compiler-macro
- `(lambda (_w x)
- ,(if (symbolp (cadr y))
- `(list ',(cadr y)
- (list ',(cl-caddr y) x))
- (cons 'list (cdr y))))))
- '((cl-first 'car x) (cl-second 'cadr x) (cl-third 'cl-caddr x) (cl-fourth 'cl-cadddr x)
- (cl-fifth 'nth 4 x) (cl-sixth 'nth 5 x) (cl-seventh 'nth 6 x)
- (cl-eighth 'nth 7 x) (cl-ninth 'nth 8 x) (cl-tenth 'nth 9 x)
- (cl-rest 'cdr x) (cl-endp 'null x) (cl-plusp '> x 0) (cl-minusp '< x 0)
- (cl-caaar car caar) (cl-caadr car cadr) (cl-cadar car cdar)
- (cl-caddr car cddr) (cl-cdaar cdr caar) (cl-cdadr cdr cadr)
- (cl-cddar cdr cdar) (cl-cdddr cdr cddr) (cl-caaaar car cl-caaar)
- (cl-caaadr car cl-caadr) (cl-caadar car cl-cadar) (cl-caaddr car cl-caddr)
- (cl-cadaar car cl-cdaar) (cl-cadadr car cl-cdadr) (cl-caddar car cl-cddar)
- (cl-cadddr car cl-cdddr) (cl-cdaaar cdr cl-caaar) (cl-cdaadr cdr cl-caadr)
- (cl-cdadar cdr cl-cadar) (cl-cdaddr cdr cl-caddr) (cl-cddaar cdr cl-cdaar)
- (cl-cddadr cdr cl-cdadr) (cl-cdddar cdr cl-cddar) (cl-cddddr cdr cl-cdddr) ))
+;;;###autoload
+(defun cl--compiler-macro-cXXr (form x)
+ (let* ((head (car form))
+ (n (symbol-name (car form)))
+ (i (- (length n) 2)))
+ (if (not (string-match "c[ad]+r\\'" n))
+ (if (and (fboundp head) (symbolp (symbol-function head)))
+ (cl--compiler-macro-cXXr (cons (symbol-function head) (cdr form))
+ x)
+ (error "Compiler macro for cXXr applied to non-cXXr form"))
+ (while (> i (match-beginning 0))
+ (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x))
+ (setq i (1- i)))
+ x)))
+
+(dolist (y '(cl-first cl-second cl-third cl-fourth
+ cl-fifth cl-sixth cl-seventh
+ cl-eighth cl-ninth cl-tenth
+ cl-rest cl-endp cl-plusp cl-minusp
+ cl-caaar cl-caadr cl-cadar
+ cl-caddr cl-cdaar cl-cdadr
+ cl-cddar cl-cdddr cl-caaaar
+ cl-caaadr cl-caadar cl-caaddr
+ cl-cadaar cl-cadadr cl-caddar
+ cl-cadddr cl-cdaaar cl-cdaadr
+ cl-cdadar cl-cdaddr cl-cddaar
+ cl-cddadr cl-cdddar cl-cddddr))
+ (put y 'side-effect-free t))
;;; Things that are inline.
-(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany cl-notevery
- cl-set-elt cl-revappend cl-nreconc gethash))
+(cl-proclaim '(inline cl-floatp-safe cl-acons cl-map cl-concatenate cl-notany
+ cl-notevery cl--set-elt cl-revappend cl-nreconc gethash))
;;; Things that are side-effect-free.
(mapc (lambda (x) (put x 'side-effect-free t))
;; generated-autoload-file: "cl-loaddefs.el"
;; End:
+(provide 'cl-macs)
+
;;; cl-macs.el ends here
HCoop / bpt / emacs.git / blobdiff