X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/e100022976f0e878ce88cf4a0230cbee86951ba1..568b1feb58c0a7d9e0fb163ab216a92abd74acf4:/lisp/emacs-lisp/cl-macs.el diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5fc8c9f9a4..d48ab7d80a 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -89,10 +89,11 @@ ;; These are used by various ;; macro expanders to optimize the results in certain common cases. -(defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max - car-safe cdr-safe progn prog1 prog2)) -(defconst cl--safe-funcs '(* / % length memq list vector vectorp - < > <= >= = error)) +(eval-and-compile + (defconst cl--simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max + car-safe cdr-safe progn prog1 prog2)) + (defconst cl--safe-funcs '(* / % length memq list vector vectorp + < > <= >= = error))) (defun cl--simple-expr-p (x &optional size) "Check if no side effects, and executes quickly." @@ -113,16 +114,17 @@ (setq xs (cdr xs))) (not xs)) -(defun cl--safe-expr-p (x) - "Check if no side effects." - (or (not (and (consp x) (not (memq (car x) '(quote function cl-function))))) - (and (symbolp (car x)) - (or (memq (car x) cl--simple-funcs) - (memq (car x) cl--safe-funcs) - (get (car x) 'side-effect-free)) - (progn - (while (and (setq x (cdr x)) (cl--safe-expr-p (car x)))) - (null x))))) +(eval-and-compile + (defun cl--safe-expr-p (x) + "Check if no side effects." + (or (not (and (consp x) (not (memq (car x) '(quote function cl-function))))) + (and (symbolp (car x)) + (or (memq (car x) cl--simple-funcs) + (memq (car x) cl--safe-funcs) + (get (car x) 'side-effect-free)) + (progn + (while (and (setq x (cdr x)) (cl--safe-expr-p (car x)))) + (null x)))))) ;;; Check if constant (i.e., no side effects or dependencies). (defun cl--const-expr-p (x) @@ -134,30 +136,30 @@ ((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)) @@ -218,71 +220,73 @@ The name is made by appending a number to PREFIX, default \"G\"." (def-edebug-spec cl-type-spec sexp) -(defconst cl--lambda-list-keywords - '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) +(eval-and-compile + (defconst cl--lambda-list-keywords + '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) -(defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) -(defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms) + (defvar cl--bind-block) (defvar cl--bind-defs) (defvar cl--bind-enquote) + (defvar cl--bind-inits) (defvar cl--bind-lets) (defvar cl--bind-forms)) -(defun cl--transform-lambda (form bind-block) - "Transform a function form FORM of name BIND-BLOCK. +(eval-and-compile + (defun cl--transform-lambda (form bind-block) + "Transform a function form FORM of name BIND-BLOCK. BIND-BLOCK is the name of the symbol to which the function will be bound, and which will be used for the name of the `cl-block' surrounding the function's body. FORM is of the form (ARGS . BODY)." - (let* ((args (car form)) (body (cdr form)) (orig-args args) - (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) - (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) - (header nil) (simple-args nil)) - (while (or (stringp (car body)) - (memq (car-safe (car body)) '(interactive declare cl-declare))) - (push (pop body) header)) - (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) - (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) - (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) - (setq args (delq '&cl-defs (delq cl--bind-defs args)) - cl--bind-defs (cadr cl--bind-defs))) - (if (setq cl--bind-enquote (memq '&cl-quote args)) - (setq args (delq '&cl-quote args))) - (if (memq '&whole args) (error "&whole not currently implemented")) - (let* ((p (memq '&environment args)) (v (cadr p)) - (env-exp 'macroexpand-all-environment)) - (if p (setq args (nconc (delq (car p) (delq v args)) - (list '&aux (list v env-exp)))))) - (while (and args (symbolp (car args)) - (not (memq (car args) '(nil &rest &body &key &aux))) - (not (and (eq (car args) '&optional) - (or cl--bind-defs (consp (cadr args)))))) - (push (pop args) simple-args)) - (or (eq cl--bind-block 'cl-none) - (setq body (list `(cl-block ,cl--bind-block ,@body)))) - (if (null args) - (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) - (if (memq '&optional simple-args) (push '&optional args)) - (cl--do-arglist args nil (- (length simple-args) - (if (memq '&optional simple-args) 1 0))) - (setq cl--bind-lets (nreverse cl--bind-lets)) - (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) - ,@(nreverse cl--bind-inits))) - (nconc (nreverse simple-args) - (list '&rest (car (pop cl--bind-lets)))) - (nconc (let ((hdr (nreverse header))) - ;; Macro expansion can take place in the middle of - ;; apparently harmless computation, so it should not - ;; touch the match-data. - (save-match-data - (require 'help-fns) - (cons (help-add-fundoc-usage - (if (stringp (car hdr)) (pop hdr)) - ;; Be careful with make-symbol and (back)quote, - ;; see bug#12884. - (let ((print-gensym nil) (print-quoted t)) - (format "%S" (cons 'fn (cl--make-usage-args - orig-args))))) - hdr))) - (list `(let* ,cl--bind-lets - ,@(nreverse cl--bind-forms) - ,@body))))))) + (let* ((args (car form)) (body (cdr form)) (orig-args args) + (cl--bind-block bind-block) (cl--bind-defs nil) (cl--bind-enquote nil) + (cl--bind-inits nil) (cl--bind-lets nil) (cl--bind-forms nil) + (header nil) (simple-args nil)) + (while (or (stringp (car body)) + (memq (car-safe (car body)) '(interactive declare cl-declare))) + (push (pop body) header)) + (setq args (if (listp args) (cl-copy-list args) (list '&rest args))) + (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p))))) + (if (setq cl--bind-defs (cadr (memq '&cl-defs args))) + (setq args (delq '&cl-defs (delq cl--bind-defs args)) + cl--bind-defs (cadr cl--bind-defs))) + (if (setq cl--bind-enquote (memq '&cl-quote args)) + (setq args (delq '&cl-quote args))) + (if (memq '&whole args) (error "&whole not currently implemented")) + (let* ((p (memq '&environment args)) (v (cadr p)) + (env-exp 'macroexpand-all-environment)) + (if p (setq args (nconc (delq (car p) (delq v args)) + (list '&aux (list v env-exp)))))) + (while (and args (symbolp (car args)) + (not (memq (car args) '(nil &rest &body &key &aux))) + (not (and (eq (car args) '&optional) + (or cl--bind-defs (consp (cadr args)))))) + (push (pop args) simple-args)) + (or (eq cl--bind-block 'cl-none) + (setq body (list `(cl-block ,cl--bind-block ,@body)))) + (if (null args) + (cl-list* nil (nreverse simple-args) (nconc (nreverse header) body)) + (if (memq '&optional simple-args) (push '&optional args)) + (cl--do-arglist args nil (- (length simple-args) + (if (memq '&optional simple-args) 1 0))) + (setq cl--bind-lets (nreverse cl--bind-lets)) + (cl-list* (and cl--bind-inits `(cl-eval-when (compile load eval) + ,@(nreverse cl--bind-inits))) + (nconc (nreverse simple-args) + (list '&rest (car (pop cl--bind-lets)))) + (nconc (let ((hdr (nreverse header))) + ;; Macro expansion can take place in the middle of + ;; apparently harmless computation, so it should not + ;; touch the match-data. + (save-match-data + (require 'help-fns) + (cons (help-add-fundoc-usage + (if (stringp (car hdr)) (pop hdr)) + ;; Be careful with make-symbol and (back)quote, + ;; see bug#12884. + (let ((print-gensym nil) (print-quoted t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args))))) + hdr))) + (list `(let* ,cl--bind-lets + ,@(nreverse cl--bind-forms) + ,@body)))))))) ;;;###autoload (defmacro cl-defun (name args &rest body) @@ -383,8 +387,6 @@ its argument list allows full Common Lisp conventions." (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 @@ -526,8 +528,7 @@ its argument list allows full Common Lisp conventions." 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)) @@ -557,17 +558,18 @@ its argument list allows full Common Lisp conventions." (cl--do-arglist (pop args) nil)))) (if args (error "Malformed argument list %s" save-args))))) -(defun cl--arglist-args (args) - (if (nlistp args) (list args) - (let ((res nil) (kind nil) arg) - (while (consp args) - (setq arg (pop args)) - (if (memq arg cl--lambda-list-keywords) (setq kind arg) - (if (eq arg '&cl-defs) (pop args) - (and (consp arg) kind (setq arg (car arg))) - (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) - (setq res (nconc res (cl--arglist-args arg)))))) - (nconc res (and args (list args)))))) +(eval-and-compile + (defun cl--arglist-args (args) + (if (nlistp args) (list args) + (let ((res nil) (kind nil) arg) + (while (consp args) + (setq arg (pop args)) + (if (memq arg cl--lambda-list-keywords) (setq kind arg) + (if (eq arg '&cl-defs) (pop args) + (and (consp arg) kind (setq arg (car arg))) + (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg))) + (setq res (nconc res (cl--arglist-args arg)))))) + (nconc res (and args (list args))))))) ;;;###autoload (defmacro cl-destructuring-bind (args expr &rest body) @@ -584,8 +586,6 @@ its argument list allows full Common Lisp conventions." ;;; The `cl-eval-when' form. -(defvar cl--not-toplevel nil) - ;;;###autoload (defmacro cl-eval-when (when &rest body) "Control when BODY is evaluated. @@ -595,29 +595,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. \(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) @@ -763,16 +741,17 @@ This is compatible with Common Lisp, but note that `defun' and ;;; The "cl-loop" macro. -(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) -(defvar cl--loop-bindings) (defvar cl--loop-body) -(defvar cl--loop-finally) -(defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop? -(defvar cl--loop-first-flag) -(defvar cl--loop-initially) (defvar cl--loop-iterator-function) -(defvar cl--loop-name) -(defvar cl--loop-result) (defvar cl--loop-result-explicit) -(defvar cl--loop-result-var) (defvar cl--loop-steps) -(defvar cl--loop-symbol-macs) +(eval-and-compile + (defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) + (defvar cl--loop-bindings) (defvar cl--loop-body) + (defvar cl--loop-finally) + (defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop? + (defvar cl--loop-first-flag) + (defvar cl--loop-initially) (defvar cl--loop-iterator-function) + (defvar cl--loop-name) + (defvar cl--loop-result) (defvar cl--loop-result-explicit) + (defvar cl--loop-result-var) (defvar cl--loop-steps) + (defvar cl--loop-symbol-macs)) (defun cl--loop-set-iterator-function (kind iterator) (if cl--loop-iterator-function @@ -1550,12 +1529,14 @@ If BODY is `setq', then use SPECS for assignments rather than for bindings." (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) @@ -1886,13 +1867,13 @@ This is like `cl-flet', but for macros instead of functions. 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) @@ -1913,8 +1894,8 @@ except that it additionally expands symbol macros." (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)) @@ -1932,7 +1913,7 @@ except that it additionally expands symbol macros." (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))) @@ -2591,7 +2572,7 @@ non-nil value, that slot cannot be set via `setf'. (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))))) @@ -2600,8 +2581,8 @@ non-nil value, that slot cannot be set via `setf'. "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. @@ -2609,8 +2590,8 @@ 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)) -(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. @@ -2618,11 +2599,11 @@ 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))) -(put 'cl-struct-slot-offset 'side-effect-free t) (defvar byte-compile-function-environment) (defvar byte-compile-macro-environment) @@ -2689,8 +2670,7 @@ TYPE is a Common Lisp-style type specifier." (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 @@ -2866,8 +2846,7 @@ The function's arguments should be treated as immutable. (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)) @@ -2875,12 +2854,11 @@ The function's arguments should be treated as immutable. (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)))) @@ -2912,16 +2890,16 @@ The function's arguments should be treated as immutable. ;;; 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)) @@ -2931,62 +2909,28 @@ The function's arguments should be treated as immutable. (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)