;;; 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, 2011 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; 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.
(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))))
;;;###autoload
(defmacro return-from (name &optional result)
"Return from the block named NAME.
-This jump out to the innermost enclosing `(block NAME ...)' form,
+This jumps out to the innermost enclosing `(block NAME ...)' form,
returning RESULT from that form (or nil if RESULT is omitted).
This is compatible with Common Lisp, but note that `defun' and
`defmacro' do not create implicit blocks as they do in Common Lisp."
(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 VARLIST, 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 nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))
\(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
- (if (listp arg1)
+ (if (and (listp arg1) (consp args))
(let* ((largs nil) (largsr nil)
(temps nil) (tempsr nil)
(restarg nil) (rest-temps nil)
(defsetf frame-parameters modify-frame-parameters t)
(defsetf frame-visible-p cl-set-frame-visible-p)
(defsetf frame-width set-screen-width t)
-(defsetf frame-parameter set-frame-parameter)
+(defsetf frame-parameter set-frame-parameter t)
(defsetf getenv setenv t)
(defsetf get-register set-register)
(defsetf global-key-binding global-set-key)
method
(error "Setf-method for %s returns malformed method"
func)))
- (and (save-match-data
- (string-match "\\`c[ad][ad][ad]?[ad]?r\\'" name))
+ (and (string-match-p "\\`c[ad][ad][ad]?[ad]?r\\'" name)
(get-setf-method (compiler-macroexpand place)))
(and (eq func 'edebug-after)
(get-setf-method (nth (1- (length place)) place)
;;;###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'.
-\(fn (NAME OPTIONS...) (SLOT SLOT-OPTS...)...)"
+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.
+
+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."
((eq type 'real) `(numberp ,val))
((eq type 'fixnum) `(integerp ,val))
;; FIXME: Should `character' accept things like ?\C-\M-a ? -stef
- ((memq type '(character string-char)) `(char-valid-p ,val))
+ ((memq type '(character string-char)) `(characterp ,val))
(t
(let* ((name (symbol-name type))
(namep (intern (concat name "p"))))
(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',