X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/a54fdddbe5d8fd6e62e4f521abc188dac3a10a8a..220d91b834f7f7252b9953460422151b86b3520c:/lisp/emacs-lisp/cl-macs.el diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index a2c6218d83..f6d66c64c7 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,11 +1,12 @@ ;;; 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 ;; Version: 2.02 ;; Keywords: extensions +;; Package: emacs ;; This file is part of GNU Emacs. @@ -128,6 +129,12 @@ (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 @@ -222,10 +229,16 @@ its argument list allows full Common Lisp conventions." (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) @@ -426,7 +439,7 @@ its argument list allows full Common Lisp conventions." ;;;###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)) @@ -485,7 +498,7 @@ The result of the body appears to the compiler as a quoted constant." (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)))) @@ -1448,8 +1461,10 @@ lexical closures as in Common Lisp. ;;;###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)) @@ -1755,6 +1770,7 @@ Example: (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) @@ -1798,19 +1814,34 @@ Example: (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*)) @@ -2183,11 +2214,21 @@ from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" ;;;###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) @@ -2430,6 +2471,7 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors. ;;; 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." @@ -2541,8 +2583,22 @@ and then returning foo." (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) @@ -2563,6 +2619,7 @@ and then returning foo." (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', @@ -2582,21 +2639,36 @@ surrounded by (block NAME ...). (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))))