((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)))
+ (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."
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))
(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 (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)
(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)