;; These are used by various
;; macro expanders to optimize the results in certain common cases.
-(defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
- car-safe cdr-safe progn prog1 prog2))
-(defconst cl--safe-funcs '(* / % length memq list vector vectorp
- < > <= >= = error))
+(eval-and-compile
+ (defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
+ car-safe cdr-safe progn prog1 prog2))
+ (defconst cl--safe-funcs '(* / % length memq list vector vectorp
+ < > <= >= = error)))
(defun cl--simple-expr-p (x &optional size)
"Check if no side effects, and executes quickly."
(setq xs (cdr xs)))
(not xs))
-(defun cl--safe-expr-p (x)
- "Check if no side effects."
- (or (not (and (consp x) (not (memq (car x) '(quote function cl-function)))))
- (and (symbolp (car x))
- (or (memq (car x) cl--simple-funcs)
- (memq (car x) cl--safe-funcs)
- (get (car x) 'side-effect-free))
- (progn
- (while (and (setq x (cdr x)) (cl--safe-expr-p (car x))))
- (null x)))))
+(eval-and-compile
+ (defun cl--safe-expr-p (x)
+ "Check if no side effects."
+ (or (not (and (consp x) (not (memq (car x) '(quote function cl-function)))))
+ (and (symbolp (car x))
+ (or (memq (car x) cl--simple-funcs)
+ (memq (car x) cl--safe-funcs)
+ (get (car x) 'side-effect-free))
+ (progn
+ (while (and (setq x (cdr x)) (cl--safe-expr-p (car x))))
+ (null x))))))
;;; Check if constant (i.e., no side effects or dependencies).
(defun cl--const-expr-p (x)
(t t)))
(defun cl--const-expr-val (x)
- (and (macroexp-const-p x) (if (consp x) (nth 1 x) x)))
-
-(defun cl--expr-contains (x y)
- "Count number of times X refers to Y. Return nil for 0 times."
- ;; FIXME: This is naive, and it will cl-count Y as referred twice in
- ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on
- ;; non-macroexpanded code, so it may also miss some occurrences that would
- ;; only appear in the expanded code.
- (cond ((equal y x) 1)
- ((and (consp x) (not (memq (car x) '(quote function cl-function))))
- (let ((sum 0))
- (while (consp x)
- (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0))))
- (setq sum (+ sum (or (cl--expr-contains x y) 0)))
- (and (> sum 0) sum)))
- (t nil)))
+ "Return the value of X known at compile-time.
+If X is not known at compile time, return nil. Before testing
+whether X is known at compile time, macroexpand it completely in
+`macroexpand-all-environment'."
+ (let ((x (macroexpand-all x macroexpand-all-environment)))
+ (if (macroexp-const-p x)
+ (if (consp x) (nth 1 x) x))))
+
+(eval-and-compile
+ (defun cl--expr-contains (x y)
+ "Count number of times X refers to Y. Return nil for 0 times."
+ ;; FIXME: This is naive, and it will cl-count Y as referred twice in
+ ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on
+ ;; non-macroexpanded code, so it may also miss some occurrences that would
+ ;; only appear in the expanded code.
+ (cond ((equal y x) 1)
+ ((and (consp x) (not (memq (car x) '(quote function cl-function))))
+ (let ((sum 0))
+ (while (consp x)
+ (setq sum (+ sum (or (cl--expr-contains (pop x) y) 0))))
+ (setq sum (+ sum (or (cl--expr-contains x y) 0)))
+ (and (> sum 0) sum)))
+ (t nil))))
(defun cl--expr-contains-any (x y)
(while (and y (not (cl--expr-contains x (car y)))) (pop y))
(def-edebug-spec cl-type-spec sexp)
-(defconst cl--lambda-list-keywords
- '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
+(eval-and-compile
+ (defconst cl--lambda-list-keywords
+ '(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
-(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote)
-(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms)
+ (defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote)
+ (defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms))
-(defun cl--transform-lambda (form bind-block)
- "Transform a function form FORM of name BIND-BLOCK.
+(eval-and-compile
+ (defun cl--transform-lambda (form bind-block)
+ "Transform a function form FORM of name BIND-BLOCK.
BIND-BLOCK is the name of the symbol to which the function will be bound,
and which will be used for the name of the `cl-block' surrounding the
function's body.
FORM is of the form (ARGS . BODY)."
- (let* ((args (car form)) (body (cdr form)) (orig-args args)
- (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
- (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil)
- (header nil) (simple-args nil))
- (while (or (stringp (car body))
- (memq (car-safe (car body)) '(interactive declare cl-declare)))
- (push (pop body) header))
- (setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
- (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
- (if (setq cl--bind-defs (cadr (memq '&cl-defs args)))
- (setq args (delq '&cl-defs (delq cl--bind-defs args))
- cl--bind-defs (cadr cl--bind-defs)))
- (if (setq cl--bind-enquote (memq '&cl-quote args))
- (setq args (delq '&cl-quote args)))
- (if (memq '&whole args) (error "&whole not currently implemented"))
- (let* ((p (memq '&environment args)) (v (cadr p))
- (env-exp 'macroexpand-all-environment))
- (if p (setq args (nconc (delq (car p) (delq v args))
- (list '&aux (list v env-exp))))))
- (while (and args (symbolp (car args))
- (not (memq (car args) '(nil &rest &body &key &aux)))
- (not (and (eq (car args) '&optional)
- (or cl--bind-defs (consp (cadr args))))))
- (push (pop args) simple-args))
- (or (eq cl--bind-block 'cl-none)
- (setq body (list `(cl-block ,cl--bind-block ,@body))))
- (if (null args)
- (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body))
- (if (memq '&optional simple-args) (push '&optional args))
- (cl--do-arglist args nil (- (length simple-args)
- (if (memq '&optional simple-args) 1 0)))
- (setq cl--bind-lets (nreverse cl--bind-lets))
- (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval)
- ,@(nreverse cl--bind-inits)))
- (nconc (nreverse simple-args)
- (list '&rest (car (pop cl--bind-lets))))
- (nconc (let ((hdr (nreverse header)))
- ;; Macro expansion can take place in the middle of
- ;; apparently harmless computation, so it should not
- ;; touch the match-data.
- (save-match-data
- (require 'help-fns)
- (cons (help-add-fundoc-usage
- (if (stringp (car hdr)) (pop hdr))
- ;; Be careful with make-symbol and (back)quote,
- ;; see bug#12884.
- (let ((print-gensym nil) (print-quoted t))
- (format "%S" (cons 'fn (cl--make-usage-args
- orig-args)))))
- hdr)))
- (list `(let* ,cl--bind-lets
- ,@(nreverse cl--bind-forms)
- ,@body)))))))
+ (let* ((args (car form)) (body (cdr form)) (orig-args args)
+ (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil)
+ (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil)
+ (header nil) (simple-args nil))
+ (while (or (stringp (car body))
+ (memq (car-safe (car body)) '(interactive declare cl-declare)))
+ (push (pop body) header))
+ (setq args (if (listp args) (cl-copy-list args) (list '&rest args)))
+ (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
+ (if (setq cl--bind-defs (cadr (memq '&cl-defs args)))
+ (setq args (delq '&cl-defs (delq cl--bind-defs args))
+ cl--bind-defs (cadr cl--bind-defs)))
+ (if (setq cl--bind-enquote (memq '&cl-quote args))
+ (setq args (delq '&cl-quote args)))
+ (if (memq '&whole args) (error "&whole not currently implemented"))
+ (let* ((p (memq '&environment args)) (v (cadr p))
+ (env-exp 'macroexpand-all-environment))
+ (if p (setq args (nconc (delq (car p) (delq v args))
+ (list '&aux (list v env-exp))))))
+ (while (and args (symbolp (car args))
+ (not (memq (car args) '(nil &rest &body &key &aux)))
+ (not (and (eq (car args) '&optional)
+ (or cl--bind-defs (consp (cadr args))))))
+ (push (pop args) simple-args))
+ (or (eq cl--bind-block 'cl-none)
+ (setq body (list `(cl-block ,cl--bind-block ,@body))))
+ (if (null args)
+ (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body))
+ (if (memq '&optional simple-args) (push '&optional args))
+ (cl--do-arglist args nil (- (length simple-args)
+ (if (memq '&optional simple-args) 1 0)))
+ (setq cl--bind-lets (nreverse cl--bind-lets))
+ (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval)
+ ,@(nreverse cl--bind-inits)))
+ (nconc (nreverse simple-args)
+ (list '&rest (car (pop cl--bind-lets))))
+ (nconc (let ((hdr (nreverse header)))
+ ;; Macro expansion can take place in the middle of
+ ;; apparently harmless computation, so it should not
+ ;; touch the match-data.
+ (save-match-data
+ (require 'help-fns)
+ (cons (help-add-fundoc-usage
+ (if (stringp (car hdr)) (pop hdr))
+ ;; Be careful with make-symbol and (back)quote,
+ ;; see bug#12884.
+ (let ((print-gensym nil) (print-quoted t))
+ (format "%S" (cons 'fn (cl--make-usage-args
+ orig-args)))))
+ hdr)))
+ (list `(let* ,cl--bind-lets
+ ,@(nreverse cl--bind-forms)
+ ,@body))))))))
;;;###autoload
(defmacro cl-defun (name args &rest body)
(if (car res) `(progn ,(car res) ,form) form))
`(function ,func)))
-(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
-
(defun cl--make-usage-var (x)
"X can be a var or a (destructuring) lambda-list."
(cond
(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)))))
- (look `(memq ',karg ,restarg)))
+ (look `(plist-member ,restarg ',karg)))
(and def cl--bind-enquote (setq def `',def))
(if (cddr arg)
(let* ((temp (or (nth 2 arg) (make-symbol "--cl-var--")))
(cl--do-arglist (pop args) nil))))
(if args (error "Malformed argument list %s" save-args)))))
-(defun cl--arglist-args (args)
- (if (nlistp args) (list args)
- (let ((res nil) (kind nil) arg)
- (while (consp args)
- (setq arg (pop args))
- (if (memq arg cl--lambda-list-keywords) (setq kind arg)
- (if (eq arg '&cl-defs) (pop args)
- (and (consp arg) kind (setq arg (car arg)))
- (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
- (setq res (nconc res (cl--arglist-args arg))))))
- (nconc res (and args (list args))))))
+(eval-and-compile
+ (defun cl--arglist-args (args)
+ (if (nlistp args) (list args)
+ (let ((res nil) (kind nil) arg)
+ (while (consp args)
+ (setq arg (pop args))
+ (if (memq arg cl--lambda-list-keywords) (setq kind arg)
+ (if (eq arg '&cl-defs) (pop args)
+ (and (consp arg) kind (setq arg (car arg)))
+ (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
+ (setq res (nconc res (cl--arglist-args arg))))))
+ (nconc res (and args (list args)))))))
;;;###autoload
(defmacro cl-destructuring-bind (args expr &rest body)
;;; The "cl-loop" macro.
-(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars)
-(defvar cl--loop-bindings) (defvar cl--loop-body)
-(defvar cl--loop-finally)
-(defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop?
-(defvar cl--loop-first-flag)
-(defvar cl--loop-initially) (defvar cl--loop-iterator-function)
-(defvar cl--loop-name)
-(defvar cl--loop-result) (defvar cl--loop-result-explicit)
-(defvar cl--loop-result-var) (defvar cl--loop-steps)
-(defvar cl--loop-symbol-macs)
+(eval-and-compile
+ (defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars)
+ (defvar cl--loop-bindings) (defvar cl--loop-body)
+ (defvar cl--loop-finally)
+ (defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop?
+ (defvar cl--loop-first-flag)
+ (defvar cl--loop-initially) (defvar cl--loop-iterator-function)
+ (defvar cl--loop-name)
+ (defvar cl--loop-result) (defvar cl--loop-result-explicit)
+ (defvar cl--loop-result-var) (defvar cl--loop-steps)
+ (defvar cl--loop-symbol-macs))
(defun cl--loop-set-iterator-function (kind iterator)
(if cl--loop-iterator-function
(if (and (cl--unused-var-p temp) (null expr))
nil ;; Don't bother declaring/setting `temp' since it won't
;; be used when `expr' is nil, anyway.
- (when (and (eq body 'setq) (cl--unused-var-p temp))
+ (when (or (null temp)
+ (and (eq body 'setq) (cl--unused-var-p temp)))
;; Prefer a fresh uninterned symbol over "_to", to avoid
;; warnings that we set an unused variable.
(setq temp (make-symbol "--cl-var--"))
;; Make sure this temp variable is locally declared.
- (push (list (list temp)) cl--loop-bindings))
+ (when (eq body 'setq)
+ (push (list (list temp)) cl--loop-bindings)))
(push (list temp expr) new))
(while (consp spec)
(push (list (pop spec)
cl-declarations body)))
(if (cdr bindings)
`(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body))
- (if (null bindings) (cons 'progn body)
+ (if (null bindings) (macroexp-progn body)
(let* ((name (caar bindings))
(res (cl--transform-lambda (cdar bindings) name)))
(eval (car res))
- (macroexpand-all (cons 'progn body)
- (cons (cons name `(lambda ,@(cdr res)))
- macroexpand-all-environment))))))
+ (macroexpand-all (macroexp-progn body)
+ (cons (cons name `(lambda ,@(cdr res)))
+ macroexpand-all-environment))))))
(defconst cl--old-macroexpand
(if (and (boundp 'cl--old-macroexpand)
(declare (debug t))
(cons 'progn body))
;;;###autoload
-(defmacro cl-the (_type form)
- "At present this ignores TYPE and is simply equivalent to FORM."
+(defmacro cl-the (type form)
+ "Return FORM. If type-checking is enabled, assert that it is of TYPE."
(declare (indent 1) (debug (cl-type-spec form)))
- form)
+ (if (not (or (not (cl--compiling-file))
+ (< cl--optimize-speed 3)
+ (= cl--optimize-safety 3)))
+ form
+ (let* ((temp (if (cl--simple-expr-p form 3)
+ form (make-symbol "--cl-var--")))
+ (body `(progn (unless ,(cl--make-type-test temp type)
+ (signal 'wrong-type-argument
+ (list ',type ,temp ',form)))
+ ,temp)))
+ (if (eq temp form) body
+ `(let ((,temp ,form)) ,body)))))
(defvar cl--proclaim-history t) ; for future compilers
(defvar cl--declare-stack t) ; for future compilers
(put ',name 'cl-struct-include ',include)
(put ',name 'cl-struct-print ,print-auto)
,@(mapcar (lambda (x)
- `(put ',(car x) 'side-effect-free ',(cdr x)))
+ `(function-put ',(car x) 'side-effect-free ',(cdr x)))
side-eff))
forms)
`(progn ,@(nreverse (cons `',name forms)))))
-;;; Types and assertions.
-
-;;;###autoload
-(defmacro cl-deftype (name arglist &rest body)
- "Define NAME as a new data type.
-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)
- (put ',name 'cl-deftype-handler
- (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body)))))
+(defun cl-struct-sequence-type (struct-type)
+ "Return the sequence used to build STRUCT-TYPE.
+STRUCT-TYPE is a symbol naming a struct type. Return 'vector or
+'list, or nil if STRUCT-TYPE is not a struct type. "
+ (declare (side-effect-free t) (pure t))
+ (car (get struct-type 'cl-struct-type)))
+
+(defun cl-struct-slot-info (struct-type)
+ "Return a list of slot names of struct STRUCT-TYPE.
+Each entry is a list (SLOT-NAME . OPTS), where SLOT-NAME is a
+slot name symbol and OPTS is a list of slot options given to
+`cl-defstruct'. Dummy slots that represent the struct name and
+slots skipped by :initial-offset may appear in the list."
+ (declare (side-effect-free t) (pure t))
+ (get struct-type 'cl-struct-slots))
+
+(defun cl-struct-slot-offset (struct-type slot-name)
+ "Return the offset of slot SLOT-NAME in STRUCT-TYPE.
+The returned zero-based slot index is relative to the start of
+the structure data type and is adjusted for any structure name
+and :initial-offset slots. Signal error if struct STRUCT-TYPE
+does not contain SLOT-NAME."
+ (declare (side-effect-free t) (pure t))
+ (or (cl-position slot-name
+ (cl-struct-slot-info struct-type)
+ :key #'car :test #'eq)
+ (error "struct %s has no slot %s" struct-type slot-name)))
(defvar byte-compile-function-environment)
(defvar byte-compile-macro-environment)
;;; Things that are inline.
(cl-proclaim '(inline cl-acons cl-map cl-concatenate cl-notany
- cl-notevery cl--set-elt cl-revappend cl-nreconc gethash))
+ cl-notevery cl-revappend cl-nreconc gethash))
;;; Things that are side-effect-free.
-(mapc (lambda (x) (put x 'side-effect-free t))
+(mapc (lambda (x) (function-put x 'side-effect-free t))
'(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd
cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem
cl-subseq cl-list-length cl-get cl-getf))
;;; Things that are side-effect-and-error-free.
-(mapc (lambda (x) (put x 'side-effect-free 'error-free))
+(mapc (lambda (x) (function-put x 'side-effect-free 'error-free))
'(eql cl-list* cl-subst cl-acons cl-equalp
cl-random-state-p copy-tree cl-sublis))
+;;; Types and assertions.
+
+;;;###autoload
+(defmacro cl-deftype (name arglist &rest body)
+ "Define NAME as a new data type.
+The type name can then be used in `cl-typecase', `cl-check-type', etc."
+ (declare (debug cl-defmacro) (doc-string 3) (indent 2))
+ `(cl-eval-when (compile load eval)
+ (put ',name 'cl-deftype-handler
+ (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body)))))
+
+;;; Additional functions that we can now define because we've defined
+;;; `cl-defsubst' and `cl-typep'.
+
+(cl-defsubst cl-struct-slot-value (struct-type slot-name inst)
+ ;; The use of `cl-defsubst' here gives us both a compiler-macro
+ ;; and a gv-expander "for free".
+ "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE.
+STRUCT and SLOT-NAME are symbols. INST is a structure instance."
+ (declare (side-effect-free t))
+ (unless (cl-typep inst struct-type)
+ (signal 'wrong-type-argument (list struct-type inst)))
+ ;; We could use `elt', but since the byte compiler will resolve the
+ ;; branch below at compile time, it's more efficient to use the
+ ;; type-specific accessor.
+ (if (eq (cl-struct-sequence-type struct-type) 'vector)
+ (aref inst (cl-struct-slot-offset struct-type slot-name))
+ (nth (cl-struct-slot-offset struct-type slot-name) inst)))
(run-hooks 'cl-macs-load-hook)