;;; cl-macs.el --- Common Lisp macros
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
(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
(symbol-function 'byte-compile-file-form)))
(list 'byte-compile-file-form (list 'quote set))
'(byte-compile-file-form form)))
- (print set (symbol-value 'bytecomp-outbuffer)))
+ (print set (symbol-value 'byte-compile-outbuffer)))
(list 'symbol-value (list 'quote temp)))
(list 'quote (eval form))))
(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
(defun cl-byte-compile-block (cl-form)
- (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler
+ ;; Here we try to determine if a catch tag is used or not, so as to get rid
+ ;; of the catch when it's not used.
+ (if (and (fboundp 'byte-compile-form-do-effect) ; Optimizing compiler?
+ ;; FIXME: byte-compile-top-level can only be used for code that is
+ ;; closed (as the name implies), so for lexical scoping we should
+ ;; implement this optimization differently.
+ (not lexical-binding))
(progn
(let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
(cl-active-block-names (cons cl-entry cl-active-block-names))
;;; The "loop" macro.
-(defvar args) (defvar loop-accum-var) (defvar loop-accum-vars)
+(defvar loop-args) (defvar loop-accum-var) (defvar loop-accum-vars)
(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps)
(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag)
(defvar loop-initially) (defvar loop-map-form) (defvar loop-name)
(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)
;;;###autoload
-(defmacro loop (&rest args)
+(defmacro loop (&rest loop-args)
"The Common Lisp `loop' macro.
Valid clauses are:
for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
finally return EXPR, named NAME.
\(fn CLAUSE...)"
- (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args))))))
- (list 'block nil (list* 'while t args))
+ (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args))))))
+ (list 'block nil (list* 'while t loop-args))
(let ((loop-name nil) (loop-bindings nil)
(loop-body nil) (loop-steps nil)
(loop-result nil) (loop-result-explicit nil)
(loop-initially nil) (loop-finally nil)
(loop-map-form nil) (loop-first-flag nil)
(loop-destr-temps nil) (loop-symbol-macs nil))
- (setq args (append args '(cl-end-loop)))
- (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
+ (setq loop-args (append loop-args '(cl-end-loop)))
+ (while (not (eq (car loop-args) 'cl-end-loop)) (cl-parse-loop-clause))
(if loop-finish-flag
(push `((,loop-finish-flag t)) loop-bindings))
(if loop-first-flag
(setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
(list* 'block loop-name body)))))
-(defun cl-parse-loop-clause () ; uses args, loop-*
- (let ((word (pop args))
+(defun cl-parse-loop-clause () ; uses loop-*
+ (let ((word (pop loop-args))
(hash-types '(hash-key hash-keys hash-value hash-values))
(key-types '(key-code key-codes key-seq key-seqs
key-binding key-bindings)))
(cond
- ((null args)
+ ((null loop-args)
(error "Malformed `loop' macro"))
((eq word 'named)
- (setq loop-name (pop args)))
+ (setq loop-name (pop loop-args)))
((eq word 'initially)
- (if (memq (car args) '(do doing)) (pop args))
- (or (consp (car args)) (error "Syntax error on `initially' clause"))
- (while (consp (car args))
- (push (pop args) loop-initially)))
+ (if (memq (car loop-args) '(do doing)) (pop loop-args))
+ (or (consp (car loop-args)) (error "Syntax error on `initially' clause"))
+ (while (consp (car loop-args))
+ (push (pop loop-args) loop-initially)))
((eq word 'finally)
- (if (eq (car args) 'return)
- (setq loop-result-explicit (or (cl-pop2 args) '(quote nil)))
- (if (memq (car args) '(do doing)) (pop args))
- (or (consp (car args)) (error "Syntax error on `finally' clause"))
- (if (and (eq (caar args) 'return) (null loop-name))
- (setq loop-result-explicit (or (nth 1 (pop args)) '(quote nil)))
- (while (consp (car args))
- (push (pop args) loop-finally)))))
+ (if (eq (car loop-args) 'return)
+ (setq loop-result-explicit (or (cl-pop2 loop-args) '(quote nil)))
+ (if (memq (car loop-args) '(do doing)) (pop loop-args))
+ (or (consp (car loop-args)) (error "Syntax error on `finally' clause"))
+ (if (and (eq (caar loop-args) 'return) (null loop-name))
+ (setq loop-result-explicit (or (nth 1 (pop loop-args)) '(quote nil)))
+ (while (consp (car loop-args))
+ (push (pop loop-args) loop-finally)))))
((memq word '(for as))
(let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
;; Use `gensym' rather than `make-symbol'. It's important that
;; (not (eq (symbol-name var1) (symbol-name var2))) because
;; these vars get added to the cl-macro-environment.
- (let ((var (or (pop args) (gensym "--cl-var--"))))
- (setq word (pop args))
- (if (eq word 'being) (setq word (pop args)))
- (if (memq word '(the each)) (setq word (pop args)))
+ (let ((var (or (pop loop-args) (gensym "--cl-var--"))))
+ (setq word (pop loop-args))
+ (if (eq word 'being) (setq word (pop loop-args)))
+ (if (memq word '(the each)) (setq word (pop loop-args)))
(if (memq word '(buffer buffers))
- (setq word 'in args (cons '(buffer-list) args)))
+ (setq word 'in loop-args (cons '(buffer-list) loop-args)))
(cond
((memq word '(from downfrom upfrom to downto upto
above below by))
- (push word args)
- (if (memq (car args) '(downto above))
+ (push word loop-args)
+ (if (memq (car loop-args) '(downto above))
(error "Must specify `from' value for downward loop"))
- (let* ((down (or (eq (car args) 'downfrom)
- (memq (caddr args) '(downto above))))
- (excl (or (memq (car args) '(above below))
- (memq (caddr args) '(above below))))
- (start (and (memq (car args) '(from upfrom downfrom))
- (cl-pop2 args)))
- (end (and (memq (car args)
+ (let* ((down (or (eq (car loop-args) 'downfrom)
+ (memq (caddr loop-args) '(downto above))))
+ (excl (or (memq (car loop-args) '(above below))
+ (memq (caddr loop-args) '(above below))))
+ (start (and (memq (car loop-args) '(from upfrom downfrom))
+ (cl-pop2 loop-args)))
+ (end (and (memq (car loop-args)
'(to upto downto above below))
- (cl-pop2 args)))
- (step (and (eq (car args) 'by) (cl-pop2 args)))
+ (cl-pop2 loop-args)))
+ (step (and (eq (car loop-args) 'by) (cl-pop2 loop-args)))
(end-var (and (not (cl-const-expr-p end))
(make-symbol "--cl-var--")))
(step-var (and (not (cl-const-expr-p step))
(let* ((on (eq word 'on))
(temp (if (and on (symbolp var))
var (make-symbol "--cl-var--"))))
- (push (list temp (pop args)) loop-for-bindings)
+ (push (list temp (pop loop-args)) loop-for-bindings)
(push (list 'consp temp) loop-body)
(if (eq word 'in-ref)
(push (list var (list 'car temp)) loop-symbol-macs)
(push (list var (if on temp (list 'car temp)))
loop-for-sets))))
(push (list temp
- (if (eq (car args) 'by)
- (let ((step (cl-pop2 args)))
+ (if (eq (car loop-args) 'by)
+ (let ((step (cl-pop2 loop-args)))
(if (and (memq (car-safe step)
'(quote function
function*))
loop-for-steps)))
((eq word '=)
- (let* ((start (pop args))
- (then (if (eq (car args) 'then) (cl-pop2 args) start)))
+ (let* ((start (pop loop-args))
+ (then (if (eq (car loop-args) 'then) (cl-pop2 loop-args) start)))
(push (list var nil) loop-for-bindings)
- (if (or ands (eq (car args) 'and))
+ (if (or ands (eq (car loop-args) 'and))
(progn
(push `(,var
(if ,(or loop-first-flag
((memq word '(across across-ref))
(let ((temp-vec (make-symbol "--cl-vec--"))
(temp-idx (make-symbol "--cl-idx--")))
- (push (list temp-vec (pop args)) loop-for-bindings)
+ (push (list temp-vec (pop loop-args)) loop-for-bindings)
(push (list temp-idx -1) loop-for-bindings)
(push (list '< (list 'setq temp-idx (list '1+ temp-idx))
(list 'length temp-vec)) loop-body)
loop-for-sets))))
((memq word '(element elements))
- (let ((ref (or (memq (car args) '(in-ref of-ref))
- (and (not (memq (car args) '(in of)))
+ (let ((ref (or (memq (car loop-args) '(in-ref of-ref))
+ (and (not (memq (car loop-args) '(in of)))
(error "Expected `of'"))))
- (seq (cl-pop2 args))
+ (seq (cl-pop2 loop-args))
(temp-seq (make-symbol "--cl-seq--"))
- (temp-idx (if (eq (car args) 'using)
- (if (and (= (length (cadr args)) 2)
- (eq (caadr args) 'index))
- (cadr (cl-pop2 args))
+ (temp-idx (if (eq (car loop-args) 'using)
+ (if (and (= (length (cadr loop-args)) 2)
+ (eq (caadr loop-args) 'index))
+ (cadr (cl-pop2 loop-args))
(error "Bad `using' clause"))
(make-symbol "--cl-idx--"))))
(push (list temp-seq seq) loop-for-bindings)
loop-for-steps)))
((memq word hash-types)
- (or (memq (car args) '(in of)) (error "Expected `of'"))
- (let* ((table (cl-pop2 args))
- (other (if (eq (car args) 'using)
- (if (and (= (length (cadr args)) 2)
- (memq (caadr args) hash-types)
- (not (eq (caadr args) word)))
- (cadr (cl-pop2 args))
+ (or (memq (car loop-args) '(in of)) (error "Expected `of'"))
+ (let* ((table (cl-pop2 loop-args))
+ (other (if (eq (car loop-args) 'using)
+ (if (and (= (length (cadr loop-args)) 2)
+ (memq (caadr loop-args) hash-types)
+ (not (eq (caadr loop-args) word)))
+ (cadr (cl-pop2 loop-args))
(error "Bad `using' clause"))
(make-symbol "--cl-var--"))))
(if (memq word '(hash-value hash-values))
((memq word '(symbol present-symbol external-symbol
symbols present-symbols external-symbols))
- (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args))))
+ (let ((ob (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))))
(setq loop-map-form
`(mapatoms (lambda (,var) . --cl-map) ,ob))))
((memq word '(overlay overlays extent extents))
(let ((buf nil) (from nil) (to nil))
- (while (memq (car args) '(in of from to))
- (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
- ((eq (car args) 'to) (setq to (cl-pop2 args)))
- (t (setq buf (cl-pop2 args)))))
+ (while (memq (car loop-args) '(in of from to))
+ (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args)))
+ ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args)))
+ (t (setq buf (cl-pop2 loop-args)))))
(setq loop-map-form
`(cl-map-extents
(lambda (,var ,(make-symbol "--cl-var--"))
(let ((buf nil) (prop nil) (from nil) (to nil)
(var1 (make-symbol "--cl-var1--"))
(var2 (make-symbol "--cl-var2--")))
- (while (memq (car args) '(in of property from to))
- (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
- ((eq (car args) 'to) (setq to (cl-pop2 args)))
- ((eq (car args) 'property)
- (setq prop (cl-pop2 args)))
- (t (setq buf (cl-pop2 args)))))
+ (while (memq (car loop-args) '(in of property from to))
+ (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args)))
+ ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args)))
+ ((eq (car loop-args) 'property)
+ (setq prop (cl-pop2 loop-args)))
+ (t (setq buf (cl-pop2 loop-args)))))
(if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
(setq var1 (car var) var2 (cdr var))
(push (list var (list 'cons var1 var2)) loop-for-sets))
,buf ,prop ,from ,to))))
((memq word key-types)
- (or (memq (car args) '(in of)) (error "Expected `of'"))
- (let ((map (cl-pop2 args))
- (other (if (eq (car args) 'using)
- (if (and (= (length (cadr args)) 2)
- (memq (caadr args) key-types)
- (not (eq (caadr args) word)))
- (cadr (cl-pop2 args))
+ (or (memq (car loop-args) '(in of)) (error "Expected `of'"))
+ (let ((map (cl-pop2 loop-args))
+ (other (if (eq (car loop-args) 'using)
+ (if (and (= (length (cadr loop-args)) 2)
+ (memq (caadr loop-args) key-types)
+ (not (eq (caadr loop-args) word)))
+ (cadr (cl-pop2 loop-args))
(error "Bad `using' clause"))
(make-symbol "--cl-var--"))))
(if (memq word '(key-binding key-bindings))
loop-for-steps)))
((memq word '(window windows))
- (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
- (temp (make-symbol "--cl-var--")))
+ (let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))
+ (temp (make-symbol "--cl-var--"))
+ (minip (make-symbol "--cl-minip--")))
(push (list var (if scr
(list 'frame-selected-window scr)
'(selected-window)))
loop-for-bindings)
+ ;; If we started in the minibuffer, we need to
+ ;; ensure that next-window will bring us back there
+ ;; at some point. (Bug#7492).
+ ;; (Consider using walk-windows instead of loop if
+ ;; you care about such things.)
+ (push (list minip `(minibufferp (window-buffer ,var)))
+ loop-for-bindings)
(push (list temp nil) loop-for-bindings)
(push (list 'prog1 (list 'not (list 'eq var temp))
(list 'or temp (list 'setq temp var)))
loop-body)
- (push (list var (list 'next-window var)) loop-for-steps)))
+ (push (list var (list 'next-window var minip))
+ loop-for-steps)))
(t
(let ((handler (and (symbolp word)
(if handler
(funcall handler var)
(error "Expected a `for' preposition, found %s" word)))))
- (eq (car args) 'and))
+ (eq (car loop-args) 'and))
(setq ands t)
- (pop args))
+ (pop loop-args))
(if (and ands loop-for-bindings)
(push (nreverse loop-for-bindings) loop-bindings)
(setq loop-bindings (nconc (mapcar 'list loop-for-bindings)
((eq word 'repeat)
(let ((temp (make-symbol "--cl-var--")))
- (push (list (list temp (pop args))) loop-bindings)
+ (push (list (list temp (pop loop-args))) loop-bindings)
(push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
((memq word '(collect collecting))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum nil 'nreverse)))
(if (eq var loop-accum-var)
(push (list 'progn (list 'push what var) t) loop-body)
t) loop-body))))
((memq word '(nconc nconcing append appending))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum nil 'nreverse)))
(push (list 'progn
(list 'setq var
var what))) t) loop-body)))
((memq word '(concat concating))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum "")))
(push (list 'progn (list 'callf 'concat var what) t) loop-body)))
((memq word '(vconcat vconcating))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum [])))
(push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))
((memq word '(sum summing))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum 0)))
(push (list 'progn (list 'incf var what) t) loop-body)))
((memq word '(count counting))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum 0)))
(push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))
((memq word '(minimize minimizing maximize maximizing))
- (let* ((what (pop args))
+ (let* ((what (pop loop-args))
(temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--")))
(var (cl-loop-handle-accum nil))
(func (intern (substring (symbol-name word) 0 3)))
((eq word 'with)
(let ((bindings nil))
- (while (progn (push (list (pop args)
- (and (eq (car args) '=) (cl-pop2 args)))
+ (while (progn (push (list (pop loop-args)
+ (and (eq (car loop-args) '=) (cl-pop2 loop-args)))
bindings)
- (eq (car args) 'and))
- (pop args))
+ (eq (car loop-args) 'and))
+ (pop loop-args))
(push (nreverse bindings) loop-bindings)))
((eq word 'while)
- (push (pop args) loop-body))
+ (push (pop loop-args) loop-body))
((eq word 'until)
- (push (list 'not (pop args)) loop-body))
+ (push (list 'not (pop loop-args)) loop-body))
((eq word 'always)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
- (push (list 'setq loop-finish-flag (pop args)) loop-body)
+ (push (list 'setq loop-finish-flag (pop loop-args)) loop-body)
(setq loop-result t))
((eq word 'never)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
- (push (list 'setq loop-finish-flag (list 'not (pop args)))
+ (push (list 'setq loop-finish-flag (list 'not (pop loop-args)))
loop-body)
(setq loop-result t))
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
(or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
(push (list 'setq loop-finish-flag
- (list 'not (list 'setq loop-result-var (pop args))))
+ (list 'not (list 'setq loop-result-var (pop loop-args))))
loop-body))
((memq word '(if when unless))
- (let* ((cond (pop args))
+ (let* ((cond (pop loop-args))
(then (let ((loop-body nil))
(cl-parse-loop-clause)
(cl-loop-build-ands (nreverse loop-body))))
(else (let ((loop-body nil))
- (if (eq (car args) 'else)
- (progn (pop args) (cl-parse-loop-clause)))
+ (if (eq (car loop-args) 'else)
+ (progn (pop loop-args) (cl-parse-loop-clause)))
(cl-loop-build-ands (nreverse loop-body))))
(simple (and (eq (car then) t) (eq (car else) t))))
- (if (eq (car args) 'end) (pop args))
+ (if (eq (car loop-args) 'end) (pop loop-args))
(if (eq word 'unless) (setq then (prog1 else (setq else then))))
(let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
(if simple (nth 1 else) (list (nth 2 else))))))
((memq word '(do doing))
(let ((body nil))
- (or (consp (car args)) (error "Syntax error on `do' clause"))
- (while (consp (car args)) (push (pop args) body))
+ (or (consp (car loop-args)) (error "Syntax error on `do' clause"))
+ (while (consp (car loop-args)) (push (pop loop-args) body))
(push (cons 'progn (nreverse (cons t body))) loop-body)))
((eq word 'return)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--")))
(or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
- (push (list 'setq loop-result-var (pop args)
+ (push (list 'setq loop-result-var (pop loop-args)
loop-finish-flag nil) loop-body))
(t
(let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
(or handler (error "Expected a loop keyword, found %s" word))
(funcall handler))))
- (if (eq (car args) 'and)
- (progn (pop args) (cl-parse-loop-clause)))))
+ (if (eq (car loop-args) 'and)
+ (progn (pop loop-args) (cl-parse-loop-clause)))))
(defun cl-loop-let (specs body par) ; uses loop-*
(let ((p specs) (temps nil) (new nil))
(list* (if par 'let 'let*)
(nconc (nreverse temps) (nreverse new)) body))))
-(defun cl-loop-handle-accum (def &optional func) ; uses args, loop-*
- (if (eq (car args) 'into)
- (let ((var (cl-pop2 args)))
+(defun cl-loop-handle-accum (def &optional func) ; uses loop-*
+ (if (eq (car loop-args) 'into)
+ (let ((var (cl-pop2 loop-args)))
(or (memq var loop-accum-vars)
(progn (push (list (list var def)) loop-bindings)
(push var loop-accum-vars)))
(defmacro lexical-let* (bindings &rest body)
"Like `let*', but lexically scoped.
The main visible difference is that lambdas inside BODY, and in
-successive bindings within BINDINGS, will create lexical closures
+successive bindings within VARLIST, will create lexical closures
as in Common Lisp. This is similar to the behavior of `let*' in
Common Lisp.
\n(fn VARLIST BODY)"
(defsetf default-file-modes set-default-file-modes t)
(defsetf default-value set-default)
(defsetf documentation-property put)
-(defsetf extent-data set-extent-data)
-(defsetf extent-face set-extent-face)
-(defsetf extent-priority set-extent-priority)
-(defsetf extent-end-position (ext) (store)
- (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext)
- store) store))
-(defsetf extent-start-position (ext) (store)
- (list 'progn (list 'set-extent-endpoints store
- (list 'extent-end-position ext)) store))
(defsetf face-background (f &optional s) (x) (list 'set-face-background f x s))
(defsetf face-background-pixmap (f &optional s) (x)
(list 'set-face-background-pixmap f x s))
(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)
(list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store))
-(defsetf x-get-cutbuffer x-store-cutbuffer t)
-(defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan.
(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*))
(push (cons name t) side-eff))))
(if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
(if print-func
- (push (list 'push
- (list 'function
- (list 'lambda '(cl-x cl-s cl-n)
- (list 'and pred-form print-func)))
- 'custom-print-functions) forms))
+ (push `(push
+ ;; The auto-generated function does not pay attention to
+ ;; the depth argument cl-n.
+ (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n))
+ (and ,pred-form ,print-func))
+ custom-print-functions)
+ forms))
(push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)
(push (list* 'eval-when '(compile load eval)
(list 'put (list 'quote name) '(quote cl-struct-slots)
(cl-transform-function-property
func 'cl-compiler-macro
(cons (if (memq '&whole args) (delq '&whole args)
- (cons '--cl-whole-arg-- args)) body))
+ (cons '_cl-whole-arg args)) body))
(list 'or (list 'get (list 'quote func) '(quote byte-compile))
(list 'progn
(list 'put (list 'quote func) '(quote byte-compile)
(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))))
;; generated-autoload-file: "cl-loaddefs.el"
;; End:
-;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
;;; cl-macs.el ends here
HCoop / bpt / emacs.git / blobdiff