;; 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)
((symbolp x) (and (memq x '(nil t)) t))
(t t)))
-(defun cl--const-expr-val (x &optional environment default)
+(defun cl--const-expr-val (x)
"Return the value of X known at compile-time.
-If X is not known at compile time, return DEFAULT. Before
-testing whether X is known at compile time, macroexpand it in
-ENVIRONMENT."
- (let ((x (macroexpand-all x environment)))
+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)
- default)))
-
-(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)))
+ (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
look
`(or ,look
,(if (eq (cl--const-expr-p def) t)
- `'(nil ,(cl--const-expr-val
- def macroexpand-all-environment))
+ `'(nil ,(cl--const-expr-val def))
`(list nil ,def))))))))
(push karg keys)))))
(setq keys (nreverse keys))
(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-eval-when' form.
-(defvar cl--not-toplevel nil)
-
;;;###autoload
(defmacro cl-eval-when (when &rest body)
"Control when BODY is evaluated.
\(fn (WHEN...) BODY...)"
(declare (indent 1) (debug (sexp body)))
- (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))
- (if (or (memq 'load when) (memq :load-toplevel when))
- (if comp (cons 'progn (mapcar 'cl--compile-time-too body))
- `(if nil nil ,@body))
- (progn (if comp (eval (cons 'progn body))) nil)))
- (and (or (memq 'eval when) (memq :execute when))
- (cons 'progn body))))
-
-(defun cl--compile-time-too (form)
- (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
- (setq form (macroexpand
- form (cons '(cl-eval-when) byte-compile-macro-environment))))
- (cond ((eq (car-safe form) 'progn)
- (cons 'progn (mapcar 'cl--compile-time-too (cdr form))))
- ((eq (car-safe form) 'cl-eval-when)
- (let ((when (nth 1 form)))
- (if (or (memq 'eval when) (memq :execute when))
- `(cl-eval-when (compile ,@when) ,@(cddr form))
- form)))
- (t (eval form) form)))
+ `(eval-when ,when ,@body))
;;;###autoload
(defmacro cl-load-time-value (form &optional _read-only)
;;; 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)
(pcase exp
((pred symbolp)
;; Perform symbol-macro expansion.
- (when (cdr (assq (symbol-name exp) env))
- (setq exp (cadr (assq (symbol-name exp) env)))))
+ (when (cdr (assoc (symbol-name exp) env))
+ (setq exp (cadr (assoc (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))
(let ((letf nil) (found nil) (nbs ()))
(dolist (binding bindings)
(let* ((var (if (symbolp binding) binding (car binding)))
- (sm (assq (symbol-name var) env)))
+ (sm (assoc (symbol-name var) env)))
(push (if (not (cdr sm))
binding
(let ((nexp (cadr sm)))
(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)))))
"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)))
-(put 'cl-struct-sequence-type 'side-effect-free t)
(defun cl-struct-slot-info (struct-type)
"Return a list of slot names of struct STRUCT-TYPE.
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))
-(put 'cl-struct-slot-info 'side-effect-free t)
(defun cl-struct-slot-offset (struct-type slot-name)
"Return the offset of slot SLOT-NAME in STRUCT-TYPE.
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)))
-(put 'cl-struct-slot-offset 'side-effect-free t)
(defvar byte-compile-function-environment)
(defvar byte-compile-macro-environment)
(defun cl--compiler-macro-typep (form val type)
(if (macroexp-const-p type)
(macroexp-let2 macroexp-copyable-p temp val
- (cl--make-type-test temp (cl--const-expr-val
- type macroexpand-all-environment)))
+ (cl--make-type-test temp (cl--const-expr-val type)))
form))
;;;###autoload
(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)
- macroexpand-all-environment))))
+ (cl--const-expr-val (nth 1 keys)))))
(cond ((eq test 'eq) `(memq ,a ,list))
((eq test 'equal) `(member ,a ,list))
((or (null keys) (eq test 'eql)) `(memql ,a ,list))
(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)
- macroexpand-all-environment))))
+ (cl--const-expr-val (nth 1 keys)))))
(cond ((eq test 'eq) `(assq ,a ,list))
((eq test 'equal) `(assoc ,a ,list))
((and (macroexp-const-p a) (or (null keys) (eq test 'eql)))
- (if (floatp (cl--const-expr-val a macroexpand-all-environment))
+ (if (floatp (cl--const-expr-val a))
`(assoc ,a ,list) `(assq ,a ,list)))
(t form))))
;;; 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))
(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))
+ (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-define-compiler-macro' and `cl-typep'.
+;;; `cl-defsubst' and `cl-typep'.
-(defun cl-struct-slot-value (struct-type slot-name inst)
+(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)))
- (elt inst (cl-struct-slot-offset struct-type slot-name)))
-(put 'cl-struct-slot-value 'side-effect-free t)
-
-(defun cl-struct-set-slot-value (struct-type slot-name inst value)
- "Set the value of slot SLOT-NAME in INST of STRUCT-TYPE.
-STRUCT and SLOT-NAME are symbols. INST is a structure instance.
-VALUE is the value to which to set the given slot. Return
-VALUE."
- (unless (cl-typep inst struct-type)
- (signal 'wrong-type-argument (list struct-type inst)))
- (setf (elt inst (cl-struct-slot-offset struct-type slot-name)) value))
-
-(gv-define-simple-setter cl-struct-slot-value cl-struct-set-slot-value)
-
-(cl-define-compiler-macro cl-struct-slot-value
- (&whole orig struct-type slot-name inst)
- (or (let* ((macenv macroexpand-all-environment)
- (struct-type (cl--const-expr-val struct-type macenv))
- (slot-name (cl--const-expr-val slot-name macenv)))
- (and struct-type (symbolp struct-type)
- slot-name (symbolp slot-name)
- (assq slot-name (cl-struct-slot-info struct-type))
- (let ((idx (cl-struct-slot-offset struct-type slot-name)))
- (cl-ecase (cl-struct-sequence-type struct-type)
- (vector `(aref (cl-the ,struct-type ,inst) ,idx))
- (list `(nth ,idx (cl-the ,struct-type ,inst)))))))
- orig))
-
-(cl-define-compiler-macro cl-struct-set-slot-value
- (&whole orig struct-type slot-name inst value)
- (or (let* ((macenv macroexpand-all-environment)
- (struct-type (cl--const-expr-val struct-type macenv))
- (slot-name (cl--const-expr-val slot-name macenv)))
- (and struct-type (symbolp struct-type)
- slot-name (symbolp slot-name)
- (assq slot-name (cl-struct-slot-info struct-type))
- (let ((idx (cl-struct-slot-offset struct-type slot-name)))
- (cl-ecase (cl-struct-sequence-type struct-type)
- (vector `(setf (aref (cl-the ,struct-type ,inst) ,idx)
- ,value))
- (list `(setf (nth ,idx (cl-the ,struct-type ,inst))
- ,value))))))
- orig))
+ ;; 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)
HCoop / bpt / emacs.git / blobdiff