(and (eq (cl-const-expr-p x) t) (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 (cl-const-expr-p x) v
(if (consp x)
(progn
(defsetf frame-visible-p cl-set-frame-visible-p)
(defsetf frame-width set-screen-width t)
(defsetf frame-parameter set-frame-parameter t)
+(defsetf terminal-parameter set-terminal-parameter)
(defsetf getenv setenv t)
(defsetf get-register set-register)
(defsetf global-key-binding global-set-key)
(defsetf window-height () (store)
(list 'progn (list 'enlarge-window (list '- store '(window-height))) store))
(defsetf window-hscroll set-window-hscroll)
+(defsetf window-parameter set-window-parameter)
(defsetf window-point set-window-point)
(defsetf window-start set-window-start)
(defsetf window-width () (store)
(defsetf x-get-secondary-selection x-own-secondary-selection t)
(defsetf x-get-selection x-own-selection t)
+;; This is a hack that allows (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.
+(define-setf-method eq (place val)
+ (let ((method (get-setf-method place cl-macro-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 cl-macro-environment directly.
+;; 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 cl-macro-environment directly.
(define-setf-method apply (func arg1 &rest rest)
(or (and (memq (car-safe func) '(quote function function*))
(cons '&cl-quote args))
(list* 'cl-defsubst-expand (list 'quote argns)
(list 'quote (list* 'block name body))
- (not (or unsafe (cl-expr-access-order pbody argns)))
+ ;; We used to pass `simple' as
+ ;; (not (or unsafe (cl-expr-access-order pbody argns)))
+ ;; But this is much too simplistic since it
+ ;; does not pay attention to the argvs (and
+ ;; cl-expr-access-order itself is also too naive).
+ nil
(and (memq '&key args) 'cl-whole) unsafe argns)))
(list* 'defun* name args body))))
(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 ((lets (delq nil
- (mapcar* (function
- (lambda (argn argv)
- (if (or simple (cl-const-expr-p argv))
- (progn (setq body (subst argv argn body))
- (and unsafe (list argn argv)))
- (list argn argv))))
- argns argvs))))
+ (let* ((substs ())
+ (lets (delq nil
+ (mapcar* (function
+ (lambda (argn argv)
+ (if (or simple (cl-const-expr-p argv))
+ (progn (push (cons argn argv) substs)
+ (and unsafe (list argn argv)))
+ (list argn argv))))
+ argns argvs))))
+ ;; FIXME: `sublis/subst' will happily substitute the symbol
+ ;; `argn' in places where it's not used as a reference
+ ;; to a variable.
+ ;; FIXME: `sublis/subst' will happily copy `argv' to a different
+ ;; scope, leading to name capture.
+ (setq body (cond ((null substs) body)
+ ((null (cdr substs))
+ (subst (cdar substs) (caar substs) body))
+ (t (sublis substs body))))
(if lets (list 'let lets body) body))))