;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
-;; Version: 2.02
+;; Version: 1.0
;; Keywords: extensions
;; This file is part of GNU Emacs.
;;; Code:
+(require 'macroexp)
+
(defvar cl-optimize-speed 1)
(defvar cl-optimize-safety 1)
;;;###autoload
(define-obsolete-variable-alias
;; This alias is needed for compatibility with .elc files that use defstruct
- ;; and were compiled with Emacs<24.2.
- 'custom-print-functions 'cl-custom-print-functions "24.2")
+ ;; and were compiled with Emacs<24.3.
+ 'custom-print-functions 'cl-custom-print-functions "24.3")
;;;###autoload
(defvar cl-custom-print-functions nil
;;; Generalized variables.
;; These macros are defined here so that they
-;; can safely be used in .emacs files.
+;; can safely be used in init files.
(defmacro cl-incf (place &optional x)
"Increment PLACE by X (1 by default).
-PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
+PLACE may be a symbol, or any generalized variable allowed by `setf'.
The return value is the incremented value of PLACE."
(declare (debug (place &optional form)))
(if (symbolp place)
(defmacro cl-decf (place &optional x)
"Decrement PLACE by X (1 by default).
-PLACE may be a symbol, or any generalized variable allowed by `cl-setf'.
+PLACE may be a symbol, or any generalized variable allowed by `setf'.
The return value is the decremented value of PLACE."
(declare (debug cl-incf))
(if (symbolp place)
(list 'setq place (if x (list '- place x) (list '1- place)))
(list 'cl-callf '- place (or x 1))))
-;; Autoloaded, but we haven't loaded cl-loaddefs yet.
-(declare-function cl-do-pop "cl-macs" (place))
-
-(defmacro cl-pop (place)
- "Remove and return the head of the list stored in PLACE.
-Analogous to (prog1 (car PLACE) (cl-setf PLACE (cdr PLACE))), though more
-careful about evaluating each argument only once and in the right order.
-PLACE may be a symbol, or any generalized variable allowed by `cl-setf'."
- (declare (debug (place)))
- (if (symbolp place)
- (list 'car (list 'prog1 place (list 'setq place (list 'cdr place))))
- (cl-do-pop place)))
-
-(defmacro cl-push (x place)
- "Insert X at the head of the list stored in PLACE.
-Analogous to (cl-setf PLACE (cons X PLACE)), though more careful about
-evaluating each argument only once and in the right order. PLACE may
-be a symbol, or any generalized variable allowed by `cl-setf'."
- (declare (debug (form place)))
- (if (symbolp place) (list 'setq place (list 'cons x place))
- (list 'cl-callf2 'cons x place)))
-
(defmacro cl-pushnew (x place &rest keys)
"(cl-pushnew X PLACE): insert X at the head of the list if not already there.
-Like (cl-push X PLACE), except that the list is unmodified if X is `eql' to
+Like (push X PLACE), except that the list is unmodified if X is `eql' to
an element already on the list.
\nKeywords supported: :test :test-not :key
\n(fn X PLACE [KEYWORD VALUE]...)"
[keywordp form])))
(if (symbolp place)
(if (null keys)
- `(let ((x ,x))
- (if (memql x ,place)
+ (macroexp-let2 nil var x
+ `(if (memql ,var ,place)
;; This symbol may later on expand to actual code which then
- ;; trigger warnings like "value unused" since cl-pushnew's return
- ;; value is rarely used. It should not matter that other
- ;; warnings may be silenced, since `place' is used earlier and
- ;; should have triggered them already.
+ ;; trigger warnings like "value unused" since cl-pushnew's
+ ;; return value is rarely used. It should not matter that
+ ;; other warnings may be silenced, since `place' is used
+ ;; earlier and should have triggered them already.
(with-no-warnings ,place)
- (setq ,place (cons x ,place))))
+ (setq ,place (cons ,var ,place))))
(list 'setq place (cl-list* 'cl-adjoin x place keys)))
(cl-list* 'cl-callf2 'cl-adjoin x place keys)))
(defun cl--set-elt (seq n val)
(if (listp seq) (setcar (nthcdr n seq) val) (aset seq n val)))
-(defsubst cl--set-nthcdr (n list x)
- (if (<= n 0) x (setcdr (nthcdr (1- n) list) x) list))
-
(defun cl--set-buffer-substring (start end val)
(save-excursion (delete-region start end)
(goto-char start)
;; simulated. Instead, cl-multiple-value-bind and friends simply expect
;; the target form to return the values as a list.
-(defalias 'cl-values #'list
+(defun cl--defalias (cl-f el-f &optional doc)
+ (defalias cl-f el-f doc)
+ (put cl-f 'byte-optimizer 'byte-compile-inline-expand))
+
+(cl--defalias 'cl-values #'list
"Return multiple values, Common Lisp style.
The arguments of `cl-values' are the values
that the containing function should return.
\(fn &rest VALUES)")
-(put 'cl-values 'byte-optimizer 'byte-compile-inline-expand)
-(defalias 'cl-values-list #'identity
+(cl--defalias 'cl-values-list #'identity
"Return multiple values, Common Lisp style, taken from a list.
LIST specifies the list of values
that the containing function should return.
\(fn LIST)")
-(put 'cl-values-list 'byte-optimizer 'byte-compile-inline-expand)
(defsubst cl-multiple-value-list (expression)
"Return a list of the multiple values produced by EXPRESSION.
"Apply FUNCTION to ARGUMENTS, taking multiple values into account.
This implementation only handles the case where there is only one argument.")
-(defsubst cl-nth-value (n expression)
+(cl--defalias 'cl-nth-value #'nth
"Evaluate EXPRESSION to get multiple values and return the Nth one.
This handles multiple values in Common Lisp style, but it does not work
right when EXPRESSION calls an ordinary Emacs Lisp function that returns just
-one value."
- (nth n expression))
+one value.
+
+\(fn N EXPRESSION)")
;;; Declarations.
(defvar cl-proclaims-deferred nil)
(defun cl-proclaim (spec)
+ "Record a global declaration specified by SPEC."
(if (fboundp 'cl-do-proclaim) (cl-do-proclaim spec t)
(push spec cl-proclaims-deferred))
nil)
(defmacro cl-declaim (&rest specs)
- (let ((body (mapcar (function (lambda (x) (list 'cl-proclaim (list 'quote x))))
+ "Like `cl-proclaim', but takes any number of unevaluated, unquoted arguments.
+Puts `(cl-eval-when (compile load eval) ...)' around the declarations
+so that they are registered at compile-time as well as run-time."
+ (let ((body (mapcar (function (lambda (x)
+ (list 'cl-proclaim (list 'quote x))))
specs)))
(if (cl--compiling-file) (cl-list* 'cl-eval-when '(compile load eval) body)
(cons 'progn body)))) ; avoid loading cl-macs.el for cl-eval-when
;;; Symbols.
-(defun cl-random-time ()
+(defun cl--random-time ()
(let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
(while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i))))
v))
-(defvar cl--gensym-counter (* (logand (cl-random-time) 1023) 100))
+(defvar cl--gensym-counter (* (logand (cl--random-time) 1023) 100))
;;; Numbers.
always returns nil."
(and (numberp object) (not (integerp object))))
-(defun cl-plusp (number)
+(defsubst cl-plusp (number)
"Return t if NUMBER is positive."
(> number 0))
-(defun cl-minusp (number)
+(defsubst cl-minusp (number)
"Return t if NUMBER is negative."
(< number 0))
"Return t if INTEGER is even."
(eq (logand integer 1) 0))
-(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl-random-time)))
+(defvar cl--random-state (vector 'cl-random-state-tag -1 30 (cl--random-time)))
(defconst cl-most-positive-float nil
"The largest value that a Lisp float can hold.
;;; Sequence functions.
-(defalias 'cl-copy-seq 'copy-sequence)
+(cl--defalias 'cl-copy-seq 'copy-sequence)
(declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs))
(nreverse cl-res)))
(mapcar cl-func cl-x)))
-(defalias 'cl-svref 'aref)
+(cl--defalias 'cl-svref 'aref)
;;; List functions.
-(defalias 'cl-first 'car)
-(defalias 'cl-second 'cadr)
-(defalias 'cl-rest 'cdr)
-(defalias 'cl-endp 'null)
-
-(defun cl-third (x)
- "Return the cl-third element of the list X."
- (car (cdr (cdr x))))
+(cl--defalias 'cl-first 'car)
+(cl--defalias 'cl-second 'cadr)
+(cl--defalias 'cl-rest 'cdr)
+(cl--defalias 'cl-endp 'null)
-(defun cl-fourth (x)
- "Return the cl-fourth element of the list X."
- (nth 3 x))
+(cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.")
+(cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.")
-(defun cl-fifth (x)
- "Return the cl-fifth element of the list X."
+(defsubst cl-fifth (x)
+ "Return the fifth element of the list X."
+ (declare (gv-setter (lambda (store) `(setcar (nthcdr 4 ,x) ,store))))
(nth 4 x))
-(defun cl-sixth (x)
- "Return the cl-sixth element of the list X."
+(defsubst cl-sixth (x)
+ "Return the sixth element of the list X."
+ (declare (gv-setter (lambda (store) `(setcar (nthcdr 5 ,x) ,store))))
(nth 5 x))
-(defun cl-seventh (x)
- "Return the cl-seventh element of the list X."
+(defsubst cl-seventh (x)
+ "Return the seventh element of the list X."
+ (declare (gv-setter (lambda (store) `(setcar (nthcdr 6 ,x) ,store))))
(nth 6 x))
-(defun cl-eighth (x)
- "Return the cl-eighth element of the list X."
+(defsubst cl-eighth (x)
+ "Return the eighth element of the list X."
+ (declare (gv-setter (lambda (store) `(setcar (nthcdr 7 ,x) ,store))))
(nth 7 x))
-(defun cl-ninth (x)
- "Return the cl-ninth element of the list X."
+(defsubst cl-ninth (x)
+ "Return the ninth element of the list X."
+ (declare (gv-setter (lambda (store) `(setcar (nthcdr 8 ,x) ,store))))
(nth 8 x))
-(defun cl-tenth (x)
- "Return the cl-tenth element of the list X."
+(defsubst cl-tenth (x)
+ "Return the tenth element of the list X."
+ (declare (gv-setter (lambda (store) `(setcar (nthcdr 9 ,x) ,store))))
(nth 9 x))
(defun cl-caaar (x)
"Return the `car' of the `car' of the `car' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(car (car (car x))))
(defun cl-caadr (x)
"Return the `car' of the `car' of the `cdr' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(car (car (cdr x))))
(defun cl-cadar (x)
"Return the `car' of the `cdr' of the `car' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(car (cdr (car x))))
(defun cl-caddr (x)
"Return the `car' of the `cdr' of the `cdr' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(car (cdr (cdr x))))
(defun cl-cdaar (x)
"Return the `cdr' of the `car' of the `car' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(cdr (car (car x))))
(defun cl-cdadr (x)
"Return the `cdr' of the `car' of the `cdr' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(cdr (car (cdr x))))
(defun cl-cddar (x)
"Return the `cdr' of the `cdr' of the `car' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(cdr (cdr (car x))))
(defun cl-cdddr (x)
"Return the `cdr' of the `cdr' of the `cdr' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(cdr (cdr (cdr x))))
(defun cl-caaaar (x)
"Return the `car' of the `car' of the `car' of the `car' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(car (car (car (car x)))))
(defun cl-caaadr (x)
"Return the `car' of the `car' of the `car' of the `cdr' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(car (car (car (cdr x)))))
(defun cl-caadar (x)
"Return the `car' of the `car' of the `cdr' of the `car' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(car (car (cdr (car x)))))
(defun cl-caaddr (x)
"Return the `car' of the `car' of the `cdr' of the `cdr' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(car (car (cdr (cdr x)))))
(defun cl-cadaar (x)
"Return the `car' of the `cdr' of the `car' of the `car' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(car (cdr (car (car x)))))
(defun cl-cadadr (x)
"Return the `car' of the `cdr' of the `car' of the `cdr' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(car (cdr (car (cdr x)))))
(defun cl-caddar (x)
"Return the `car' of the `cdr' of the `cdr' of the `car' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(car (cdr (cdr (car x)))))
(defun cl-cadddr (x)
"Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(car (cdr (cdr (cdr x)))))
(defun cl-cdaaar (x)
"Return the `cdr' of the `car' of the `car' of the `car' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(cdr (car (car (car x)))))
(defun cl-cdaadr (x)
"Return the `cdr' of the `car' of the `car' of the `cdr' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(cdr (car (car (cdr x)))))
(defun cl-cdadar (x)
"Return the `cdr' of the `car' of the `cdr' of the `car' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(cdr (car (cdr (car x)))))
(defun cl-cdaddr (x)
"Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(cdr (car (cdr (cdr x)))))
(defun cl-cddaar (x)
"Return the `cdr' of the `cdr' of the `car' of the `car' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(cdr (cdr (car (car x)))))
(defun cl-cddadr (x)
"Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(cdr (cdr (car (cdr x)))))
(defun cl-cdddar (x)
"Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(cdr (cdr (cdr (car x)))))
(defun cl-cddddr (x)
"Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
+ (declare (compiler-macro cl--compiler-macro-cXXr))
(cdr (cdr (cdr (cdr x)))))
;;(defun last* (x &optional n)
(last (nthcdr (- n 2) copy)))
(setcdr last (car (cdr last)))
(cons arg copy)))))
-(autoload 'cl--compiler-macro-list* "cl-macs")
(defun cl-ldiff (list sublist)
"Return a copy of LIST with the tail SUBLIST removed."
((or (equal cl-keys '(:test equal)) (null cl-keys))
(if (member cl-item cl-list) cl-list (cons cl-item cl-list)))
(t (apply 'cl--adjoin cl-item cl-list cl-keys))))
-(autoload 'cl--compiler-macro-adjoin "cl-macs")
(defun cl-subst (cl-new cl-old cl-tree &rest cl-keys)
"Substitute NEW for OLD everywhere in TREE (non-destructively).
(nconc (cl-mapcar 'cons keys values) alist))
+;;; Generalized variables.
+
+;; These used to be in cl-macs.el since all macros that use them (like setf)
+;; were autoloaded from cl-macs.el. But now that setf, push, and pop are in
+;; core Elisp, they need to either be right here or be autoloaded via
+;; cl-loaddefs.el, which is more trouble than it is worth.
+
+;; Some more Emacs-related place types.
+(gv-define-simple-setter buffer-file-name set-visited-file-name t)
+(gv-define-setter buffer-modified-p (flag &optional buf)
+ `(with-current-buffer ,buf
+ (set-buffer-modified-p ,flag)))
+(gv-define-simple-setter buffer-name rename-buffer t)
+(gv-define-setter buffer-string (store)
+ `(insert (prog1 ,store (erase-buffer))))
+(gv-define-simple-setter buffer-substring cl--set-buffer-substring)
+(gv-define-simple-setter current-buffer set-buffer)
+(gv-define-simple-setter current-case-table set-case-table)
+(gv-define-simple-setter current-column move-to-column t)
+(gv-define-simple-setter current-global-map use-global-map t)
+(gv-define-setter current-input-mode (store)
+ `(progn (apply #'set-input-mode ,store) ,store))
+(gv-define-simple-setter current-local-map use-local-map t)
+(gv-define-simple-setter current-window-configuration
+ set-window-configuration t)
+(gv-define-simple-setter default-file-modes set-default-file-modes t)
+(gv-define-simple-setter documentation-property put)
+(gv-define-setter face-background (x f &optional s)
+ `(set-face-background ,f ,x ,s))
+(gv-define-setter face-background-pixmap (x f &optional s)
+ `(set-face-background-pixmap ,f ,x ,s))
+(gv-define-setter face-font (x f &optional s) `(set-face-font ,f ,x ,s))
+(gv-define-setter face-foreground (x f &optional s)
+ `(set-face-foreground ,f ,x ,s))
+(gv-define-setter face-underline-p (x f &optional s)
+ `(set-face-underline ,f ,x ,s))
+(gv-define-simple-setter file-modes set-file-modes t)
+(gv-define-simple-setter frame-height set-screen-height t)
+(gv-define-simple-setter frame-parameters modify-frame-parameters t)
+(gv-define-simple-setter frame-visible-p cl--set-frame-visible-p)
+(gv-define-simple-setter frame-width set-screen-width t)
+(gv-define-simple-setter getenv setenv t)
+(gv-define-simple-setter get-register set-register)
+(gv-define-simple-setter global-key-binding global-set-key)
+(gv-define-simple-setter local-key-binding local-set-key)
+(gv-define-simple-setter mark set-mark t)
+(gv-define-simple-setter mark-marker set-mark t)
+(gv-define-simple-setter marker-position set-marker t)
+(gv-define-setter mouse-position (store scr)
+ `(set-mouse-position ,scr (car ,store) (cadr ,store)
+ (cddr ,store)))
+(gv-define-simple-setter point goto-char)
+(gv-define-simple-setter point-marker goto-char t)
+(gv-define-setter point-max (store)
+ `(progn (narrow-to-region (point-min) ,store) ,store))
+(gv-define-setter point-min (store)
+ `(progn (narrow-to-region ,store (point-max)) ,store))
+(gv-define-setter read-mouse-position (store scr)
+ `(set-mouse-position ,scr (car ,store) (cdr ,store)))
+(gv-define-simple-setter screen-height set-screen-height t)
+(gv-define-simple-setter screen-width set-screen-width t)
+(gv-define-simple-setter selected-window select-window)
+(gv-define-simple-setter selected-screen select-screen)
+(gv-define-simple-setter selected-frame select-frame)
+(gv-define-simple-setter standard-case-table set-standard-case-table)
+(gv-define-simple-setter syntax-table set-syntax-table)
+(gv-define-simple-setter visited-file-modtime set-visited-file-modtime t)
+(gv-define-setter window-height (store)
+ `(progn (enlarge-window (- ,store (window-height))) ,store))
+(gv-define-setter window-width (store)
+ `(progn (enlarge-window (- ,store (window-width)) t) ,store))
+(gv-define-simple-setter x-get-secondary-selection x-own-secondary-selection t)
+(gv-define-simple-setter x-get-selection x-own-selection t)
+
+;; More complex setf-methods.
+
+;; 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.
+;; It turned out that :variable needed more flexibility anyway, so
+;; this doesn't seem too useful now.
+(gv-define-expander eq
+ (lambda (do place val)
+ (gv-letplace (getter setter) place
+ (macroexp-let2 nil val val
+ (funcall do `(eq ,getter ,val)
+ (lambda (v)
+ `(cond
+ (,v ,(funcall setter val))
+ ((eq ,getter ,val) ,(funcall setter `(not ,val))))))))))
+
+(gv-define-expander substring
+ (lambda (do place from &optional to)
+ (gv-letplace (getter setter) place
+ (macroexp-let2 nil start from
+ (macroexp-let2 nil end to
+ (funcall do `(substring ,getter ,start ,end)
+ (lambda (v)
+ (funcall setter `(cl--set-substring
+ ,getter ,start ,end ,v)))))))))
+
;;; Miscellaneous.
;;;###autoload
(progn
+ ;; Make sure functions defined with cl-defsubst can be inlined even in
+ ;; packages which do not require CL. We don't put an autoload cookie
+ ;; directly on that function, since those cookies only go to cl-loaddefs.
+ (autoload 'cl--defsubst-expand "cl-macs")
;; Autoload, so autoload.el and font-lock can use it even when CL
;; is not loaded.
(put 'cl-defun 'doc-string-elt 3)
;; Local variables:
;; byte-compile-dynamic: t
-;; byte-compile-warnings: (not cl-functions)
;; End:
;;; cl-lib.el ends here
HCoop / bpt / emacs.git / blobdiff