;;; cl-macs.el --- Common Lisp macros
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
-(or (memq 'cl-19 features)
- (error "Tried to load `cl-macs' before `cl'!"))
-
+(require 'cl)
(defmacro cl-pop2 (place)
(list 'prog1 (list 'car (list 'cdr place))
(defvar cl-old-bc-file-form nil)
-;;;###autoload
-(defun cl-compile-time-init ()
- (run-hooks 'cl-hack-bytecomp-hook))
-
-
;;; Some predicates for analyzing Lisp forms. These are used by various
;;; macro expanders to optimize the results in certain common cases.
(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
(defconst lambda-list-keywords
'(&optional &rest &key &allow-other-keys &aux &whole &body &environment))
-(defvar cl-macro-environment nil)
+(defvar cl-macro-environment nil
+ "Keep the list of currently active macros.
+It is a list of elements of the form either:
+- (SYMBOL . FUNCTION) where FUNCTION is the macro expansion function.
+- (SYMBOL-NAME . EXPANSION) where SYMBOL-NAME is the name of a symbol macro.")
(defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
(defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
+(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
+
(defun cl-transform-lambda (form bind-block)
(let* ((args (car form)) (body (cdr form)) (orig-args args)
(bind-defs nil) (bind-enquote nil)
;;;###autoload
(defmacro destructuring-bind (args expr &rest body)
(let* ((bind-lets nil) (bind-forms nil) (bind-inits nil)
- (bind-defs nil) (bind-block 'cl-none))
+ (bind-defs nil) (bind-block 'cl-none) (bind-enquote nil))
(cl-do-arglist (or args '(&aux)) expr)
(append '(progn) bind-inits
(list (nconc (list 'let* (nreverse bind-lets))
(symbol-function 'byte-compile-file-form)))
(list 'byte-compile-file-form (list 'quote set))
'(byte-compile-file-form form)))
- (print set (symbol-value 'outbuffer)))
+ (print set (symbol-value 'bytecomp-outbuffer)))
(list 'symbol-value (list 'quote temp)))
(list 'quote (eval form))))
;;; 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)))
(let ((func (list 'function*
(list 'lambda (cadr x)
(list* 'block (car x) (cddr x))))))
- (if (and (cl-compiling-file)
- (boundp 'byte-compile-function-environment))
- (push (cons (car x) (eval func))
- byte-compile-function-environment))
+ (when (cl-compiling-file)
+ ;; Bug#411. It would be nice to fix this.
+ (and (get (car x) 'byte-compile)
+ (error "Byte-compiling a redefinition of `%s' \
+will not work - use `labels' instead" (symbol-name (car x))))
+ ;; FIXME This affects the rest of the file, when it
+ ;; should be restricted to the flet body.
+ (and (boundp 'byte-compile-function-environment)
+ (push (cons (car x) (eval func))
+ byte-compile-function-environment)))
(list (list 'symbol-function (list 'quote (car x))) func))))
bindings)
body))
;;;###autoload
(defmacro lexical-let* (bindings &rest body)
"Like `let*', but lexically scoped.
-The main visible difference is that lambdas inside BODY will create
-lexical closures as in Common Lisp.
+The main visible difference is that lambdas inside BODY, and in
+successive bindings within BINDINGS, will create lexical closures
+as in Common Lisp. This is similar to the behavior of `let*' in
+Common Lisp.
\n(fn VARLIST BODY)"
(if (null bindings) (cons 'progn body)
(setq bindings (reverse bindings))
(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*))
;;;###autoload
(defmacro defstruct (struct &rest descs)
"Define a struct type.
-This macro defines a new Lisp data type called NAME, which contains data
-stored in SLOTs. This defines a `make-NAME' constructor, a `copy-NAME'
-copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors.
+This macro defines a new data type called NAME that stores data
+in SLOTs. It defines a `make-NAME' constructor, a `copy-NAME'
+copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'.
+You can use the accessors to set the corresponding slots, via `setf'.
+
+NAME may instead take the form (NAME OPTIONS...), where each
+OPTION is either a single keyword or (KEYWORD VALUE).
+See Info node `(cl)Structures' for a list of valid keywords.
-\(fn (NAME OPTIONS...) (SLOT SLOT-OPTS...)...)"
+Each SLOT may instead take the form (SLOT SLOT-OPTS...), where
+SLOT-OPTS are keyword-value pairs for that slot. Currently, only
+one keyword is supported, `:read-only'. If this has a non-nil
+value, that slot cannot be set via `setf'.
+
+\(fn NAME SLOTS...)"
(let* ((name (if (consp struct) (car struct) struct))
(opts (cdr-safe struct))
(slots nil)
;;; Types and assertions.
+;;;###autoload
(defmacro deftype (name arglist &rest body)
"Define NAME as a new data type.
The type name can then be used in `typecase', `check-type', etc."
(list* 'list (list 'quote form) sargs))))
nil))))
-;;;###autoload
-(defmacro ignore-errors (&rest body)
- "Execute BODY; if an error occurs, return nil.
-Otherwise, return result of last form in BODY."
- `(condition-case nil (progn ,@body) (error nil)))
-
-
;;; Compiler macros.
;;;###autoload
(cons (if (memq '&whole args) (delq '&whole args)
(cons '--cl-whole-arg-- args)) body))
(list 'or (list 'get (list 'quote func) '(quote byte-compile))
- (list 'put (list 'quote func) '(quote byte-compile)
- '(quote cl-byte-compile-compiler-macro)))))
+ (list 'progn
+ (list 'put (list 'quote func) '(quote byte-compile)
+ '(quote cl-byte-compile-compiler-macro))
+ ;; This is so that describe-function can locate
+ ;; the macro definition.
+ (list 'let
+ (list (list
+ 'file
+ (or buffer-file-name
+ (and (boundp 'byte-compile-current-file)
+ (stringp byte-compile-current-file)
+ byte-compile-current-file))))
+ (list 'if 'file
+ (list 'put (list 'quote func)
+ '(quote compiler-macro-file)
+ '(purecopy (file-name-nondirectory file)))))))))
;;;###autoload
(defun compiler-macroexpand (form)
(byte-compile-normal-call form)
(byte-compile-form form)))
+;;;###autoload
(defmacro defsubst* (name args &rest body)
"Define NAME as a function.
Like `defun', except the function is automatically declared `inline',
(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