xemacs-beta: lisp/cl.el comparison

comparison lisp/cl.el @ 2153:393039450288

[xemacs-hg @ 2004-06-26 21:25:23 by james] Synch with Emacs 21.3.

author	james
date	Sat, 26 Jun 2004 21:25:24 +0000
parents	9d6ec778e1e8
children	ecf1ebac70d8

comparison

equal deleted inserted replaced

-:d93fedcbf6be
+:393039450288
 ;; You should have received a copy of the GNU General Public License
 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 ;; 02111-1307, USA.
-;;; Synched up with: FSF 19.34.
+;;; Synched up with: FSF 21.3.
 ;;; Commentary:
 ;; This file is dumped with XEmacs.
 ;; Common Lisp compatibility, beyond what is already built-in
 ;; in Emacs Lisp.
 ;;
 ;; This package was written by Dave Gillespie; it is a complete
 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986.
-;;
-;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19.
 ;;
 ;; Bug reports, comments, and suggestions are welcome!
 ;; This file contains the portions of the Common Lisp extensions
 ;; package which should always be present.
 				 (string-lessp emacs-version "19")) 18)
 			    ((string-match "XEmacs" emacs-version)
 			     'lucid)
 			    (t 19)))
-(or (fboundp 'defalias) (fset 'defalias 'fset))
 (defvar cl-optimize-speed 1)
 (defvar cl-optimize-safety 1)
-;;; Keywords used in this package.
-;;; XEmacs - keywords are done in Fintern().
-;;;
-;;; (defconst :test ':test)
-;;; (defconst :test-not ':test-not)
-;;; (defconst :key ':key)
-;;; (defconst :start ':start)
-;;; (defconst :start1 ':start1)
-;;; (defconst :start2 ':start2)
-;;; (defconst :end ':end)
-;;; (defconst :end1 ':end1)
-;;; (defconst :end2 ':end2)
-;;; (defconst :count ':count)
-;;; (defconst :initial-value ':initial-value)
-;;; (defconst :size ':size)
-;;; (defconst :from-end ':from-end)
-;;; (defconst :rehash-size ':rehash-size)
-;;; (defconst :rehash-threshold ':rehash-threshold)
-;;; (defconst :allow-other-keys ':allow-other-keys)
 (defvar custom-print-functions nil
 "This is a list of functions that format user objects for printing.
 Each function is called in turn with three arguments: the object, the
 ;; The macros `when' and `unless' are so useful that we want them to
 ;; ALWAYS be available.  So they've been moved from cl.el to eval.c.
 ;; Note: FSF Emacs moved them to subr.el in FSF 20.
-(defun cl-map-extents (&rest cl-args)
+(defalias 'cl-map-extents 'map-extents)
-;; XEmacs: This used to check for overlays first, but that's wrong
-;; because of the new compatibility library.  *duh*
-(cond ((fboundp 'map-extents)
-	 (apply 'map-extents cl-args))
-	((fboundp 'next-overlay-at)
-	 (apply 'cl-map-overlays cl-args))))
 ;;; Blocks and exits.
 (defalias 'cl-block-wrapper 'identity)
 ;;; Multiple values.  True multiple values are not supported, or even
 ;;; simulated.  Instead, multiple-value-bind and friends simply expect
 ;;; the target form to return the values as a list.
-(defalias 'values 'list)
+(defsubst values (&rest values)
-(defalias 'values-list 'identity)
+"Return multiple values, Common Lisp style.
-(defalias 'multiple-value-list 'identity)
+The arguments of `values' are the values
+that the containing function should return."
+values)
+(defsubst values-list (list)
+"Return multiple values, Common Lisp style, taken from a list.
+LIST specifies the list of values
+that the containing function should return."
+list)
+(defsubst multiple-value-list (expression)
+"Return a list of the multiple values produced by EXPRESSION.
+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."
+expression)
+(defsubst multiple-value-apply (function expression)
+"Evaluate EXPRESSION to get multiple values and apply FUNCTION to them.
+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."
+(apply function expression))
 (defalias 'multiple-value-call 'apply)  ; only works for one arg
-(defalias 'nth-value 'nth)
+(defsubst nth-value (n expression)
+"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))
 ;;; Macros.
 (defvar cl-macro-environment nil)
 ;; XEmacs: we renamed the internal function to macroexpand-internal
 	(coerce-number v 'fixnum)
 v)))
 (defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100))
+;; XEmacs change: gensym and gentemp moved here from cl-macs.el
 (defun gensym (&optional arg)
 "Generate a new uninterned symbol.
 The name is made by appending a number to a prefix.  If ARG is a string, it
 is the prefix, otherwise the prefix defaults to \"G\".  If ARG is an integer,
 the internal counter is reset to that number before creating the name.
 (setq *gensym-counter* (1+ *gensym-counter*)))
 (intern name)))
 ;;; Numbers.
+;; XEmacs change: use floatp, which is right even in the presence of ratios
+;; and bigfloats
 (defun floatp-safe (object)
 "Return t if OBJECT is a floating point number."
 (floatp object))
 (defun plusp (number)
 (defun evenp (integer)
 "Return t if INTEGER is even."
 (eq (logand integer 1) 0))
-(defun cl-abs (number)
+;; XEmacs addition
-"Return the absolute value of NUMBER."
+(defalias 'cl-abs 'abs)
-(if (>= number 0) number (- number)))
-(or (fboundp 'abs) (defalias 'abs 'cl-abs))   ; This is built-in to Emacs 19
 (defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time)))
-;; These constants are defined in C when 'number-types is provided.
+;; XEmacs: These constants are defined in C when 'number-types is provided.
+;; They are always defined in C on Emacs.  Maybe we should, too.
 (unless (featurep 'number-types)
 ;;; We use `eval' in case VALBITS differs from compile-time to load-time.
 (defconst most-positive-fixnum (eval '(lsh -1 -1))
 "The integer closest in value to positive infinity.")
 (defconst most-negative-fixnum (eval '(- -1 (lsh -1 -1)))
 	  (while (and cl-x cl-y)
 	    (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res))
 	  (nreverse cl-res)))
 (mapcar cl-func cl-x)))
+(defalias 'svref 'aref)
 ;;; List functions.
 ;; These functions are made known to the byte-compiler by cl-macs.el
 ;; and turned into efficient car and cdr bytecodes.
 (defalias 'first 'car)
 (defalias 'rest 'cdr)
 (defalias 'endp 'null)
+;; XEmacs change: make it a real function
 (defun second (x)
 "Return the second element of the list LIST."
 (car (cdr x)))
 (defun third (x)
-"Return the third element of the list LIST."
+"Return the third element of the list X."
 (car (cdr (cdr x))))
 (defun fourth (x)
-"Return the fourth element of the list LIST."
+"Return the fourth element of the list X."
 (nth 3 x))
 (defun fifth (x)
-"Return the fifth element of the list LIST."
+"Return the fifth element of the list X."
 (nth 4 x))
 (defun sixth (x)
-"Return the sixth element of the list LIST."
+"Return the sixth element of the list X."
 (nth 5 x))
 (defun seventh (x)
-"Return the seventh element of the list LIST."
+"Return the seventh element of the list X."
 (nth 6 x))
 (defun eighth (x)
-"Return the eighth element of the list LIST."
+"Return the eighth element of the list X."
 (nth 7 x))
 (defun ninth (x)
-"Return the ninth element of the list LIST."
+"Return the ninth element of the list X."
 (nth 8 x))
 (defun tenth (x)
-"Return the tenth element of the list LIST."
+"Return the tenth element of the list X."
 (nth 9 x))
+;; XEmacs change: Emacs defines caar, cadr, cdar, and cddr in subr.el.
 (defun caar (x)
 "Return the `car' of the `car' of X."
 (car (car x)))
 (defun cadr (x)
 (defun cddddr (x)
 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
 (cdr (cdr (cdr (cdr x)))))
 ;;; `last' is implemented as a C primitive, as of 1998-11
+;;(defun last* (x &optional n)
-;(defun last (x &optional n)
+;;  "Returns the last link in the list LIST.
-;  "Return the last link in the list LIST.
+;;With optional argument N, returns Nth-to-last link (default 1)."
-;With optional argument N, return Nth-to-last link (default 1)."
+;;  (if n
-;  (if n
+;;      (let ((m 0) (p x))
-;      (let ((m 0) (p x))
+;;	(while (consp p) (incf m) (pop p))
-;	(while (consp p) (incf m) (pop p))
+;;	(if (<= n 0) p
-;	(if (<= n 0) p
+;;	  (if (< n m) (nthcdr (- m n) x) x)))
-;	  (if (< n m) (nthcdr (- m n) x) x)))
+;;    (while (consp (cdr x)) (pop x))
-;    (while (consp (cdr x)) (pop x))
+;;    x))
-;    x))
-;;; `butlast'  is implemented as a C primitive, as of 1998-11
-;;; `nbutlast' is implemented as a C primitive, as of 1998-11
-;(defun butlast (x &optional n)
-;  "Return a copy of LIST with the last N elements removed."
-;  (if (and n (<= n 0)) x
-;    (nbutlast (copy-sequence x) n)))
-;(defun nbutlast (x &optional n)
-;  "Modify LIST to remove the last N elements."
-;  (let ((m (length x)))
-;    (or n (setq n 1))
-;    (and (< n m)
-;	 (progn
-;	   (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
-;	   x))))
 (defun list* (arg &rest rest)   ; See compiler macro in cl-macs.el
 "Return a new list with specified args as elements, cons'd to last arg.
 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
 `(cons A (cons B (cons C D)))'."
 (defun cl-maclisp-member (item list)
 (while (and list (not (equal item (car list)))) (setq list (cdr list)))
 list)
-;;; Define an Emacs 19-compatible `member' for the benefit of Emacs 18 users.
-(or (and (fboundp 'member) (subrp (symbol-function 'member)))
-(defalias 'member 'cl-maclisp-member))
 (defalias 'cl-member 'memq)   ; for compatibility with old CL package
 (defalias 'cl-floor 'floor*)
 (defalias 'cl-ceiling 'ceiling*)
 (defalias 'cl-truncate 'truncate*)
 (defalias 'cl-round 'round*)
 ;;; Miscellaneous.
 ;; XEmacs change
 (define-error 'cl-assertion-failed "Assertion failed")
-;;; This is defined in Emacs 19; define it here for Emacs 18 users.
+;; XEmacs change: omit the autoload rules; we handle those a different way
-(defun cl-add-hook (hook func &optional append)
-"Add to hook variable HOOK the function FUNC.
-FUNC is not added if it already appears on the list stored in HOOK."
-(let ((old (and (boundp hook) (symbol-value hook))))
-(and (listp old) (not (eq (car old) 'lambda))
-	 (setq old (list old)))
-(and (not (member func old))
-	 (set hook (if append (nconc old (list func)) (cons func old))))))
-(or (fboundp 'add-hook) (defalias 'add-hook 'cl-add-hook))
-;; XEmacs change
-;(load "cl-defs")
 ;;; Define data for indentation and edebug.
 (mapcar
 #'(lambda (entry)
 (mapcar
 (defvar cl-hacked-flag nil)
 (defun cl-hack-byte-compiler ()
 (if (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form))
 (progn
+	(setq cl-hacked-flag t)		; Do it first, to prevent recursion.
 	(when (not (fboundp 'cl-compile-time-init))
 	  (load "cl-macs" nil t))
-	(cl-compile-time-init)   ; in cl-macs.el
+	(cl-compile-time-init))))	; In cl-macs.el.
-	(setq cl-hacked-flag t))))
 ;;; Try it now in case the compiler has already been loaded.
 (cl-hack-byte-compiler)
 ;;; Also make a hook in case compiler is loaded after this file.
 ;;; The compiler doesn't call any hooks when it loads or runs, but
 ;;; we can take advantage of the fact that emacs-lisp-mode will be
 ;;; called when the compiler reads in the file to be compiled.
 ;;; BUG: If the first compilation is `byte-compile' rather than
-;;; `byte-compile-file', we lose.  Oh, well.
+;;; `byte-compile-file', we lose.  Emacs has fixed this by hanging it
+;;; on `bytecomp-load-hook' instead, which we do not have.
 (add-hook 'emacs-lisp-mode-hook 'cl-hack-byte-compiler)
 ;;; The following ensures that packages which expect the old-style cl.el
 ;;; will be happy with this one.
 (provide 'cl)
-(provide 'mini-cl)   ; for Epoch
 (run-hooks 'cl-load-hook)
+;;; arch-tag: 5f07fa74-f153-4524-9303-21f5be125851
 ;;; cl.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/cl.el @ 2153:393039450288