;;; cl-macs.el --- Common Lisp macros
-;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
;; Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; 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)
(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))))
(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 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)
;;; 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."
omitted, a default message listing FORM itself is used."
(and (or (not (cl-compiling-file))
(< cl-optimize-speed 3) (= cl-optimize-safety 3))
- (let ((sargs (and show-args (delq nil (mapcar
- (function
- (lambda (x)
- (and (not (cl-const-expr-p x))
- x))) (cdr form))))))
+ (let ((sargs (and show-args
+ (delq nil (mapcar
+ (lambda (x)
+ (unless (cl-const-expr-p x)
+ x))
+ (cdr form))))))
(list 'progn
(list 'or form
(if string
(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)