xemacs-beta: lisp/cl-extra.el comparison

comparison lisp/cl-extra.el @ 5219:2d0937dc83cf

Tidying of CL files; make docstrings read better, remove commented-out code 2010-05-30 Aidan Kehoe <kehoea@parhasard.net> * cl.el: Remove extraneous empty lines. Remove the commented-out Lisp implementation of #'last, #'copy-list. Remove #'cl-maclisp-member. (acons, pairlis): Have the argument list reflect the docstring for these functions. * cl-macs.el (defun*): Have the argument list reflect the docstring. Document the syntax of keywords in ARGLIST. (defmacro*): Have the argument list reflect the docstring. Document &body, &whole and &environment. (function*): Have the argument list reflect the docstring. (loop): Have the argument list reflect the docstring. (eval-when, dolist, dotimes, do-symbols, flet, labels, macrolet, symbol-macrolet): Specify the argument list using the arguments: (...) syntax. (define-setf-method, rotatef, defsubst*): Have the argument list reflect the docstring. (letf, letf*): Specify the argument list using the arguments: (...) syntax. (svref, acons, pairlis): Add compiler macros for these functions. * cl-extra.el: Remove the commented-out Lisp implementation of #'equalp. If we want to look at it, it's in version control. (cl-expt): Remove this. The subr #'expt is always available. Call #'cl-float-limits at dump time. Remove the commented-out Lisp implementation of #'subseq. (concatenate): Use (error 'invalid-argument ...) here, if TYPE is not understood. (list-length): Don't manually get the length of a list, call #'length and return nil if the list is circular. * byte-optimize.el (equalp): This needs byte-optimize-binary-predicate as its optimizer, as do the other equality predicates.

author	Aidan Kehoe <kehoea@parhasard.net>
date	Sun, 30 May 2010 13:27:36 +0100
parents	41262f87eb39
children	7789ae555c45

comparison

equal deleted inserted replaced

-:ec2ddc82f10d
+:2d0937dc83cf
 ;;; Code:
 ;; XEmacs addition
 (eval-when-compile
 (require 'obsolete))
-(or (memq 'cl-19 features)
-(error "Tried to load `cl-extra' before `cl'!"))
 ;;; Type coercion.
 (defun coerce (x type)
 "Coerce OBJECT to type TYPE.
 	   ((equal (cdr-safe type) '(character))
 	    (coerce x 'string)))))
 	((typep x type) x)
 	(t (error "Can't coerce %s to type %s" x type))))
+;; XEmacs; #'equalp is in C.
-;;;;; Predicates.
-;;
-;;;; I'd actually prefer not to have this inline, the space
-;;;; vs. amount-it's-called trade-off isn't reasonable, but that would
-;;;; introduce bytecode problems with the compiler macro in cl-macs.el.
-;;(defsubst cl-string-vector-equalp (cl-string cl-vector)
-;;  "Helper function for `equalp', which see."
-;;;  (check-argument-type #'stringp cl-string)
-;;;  (check-argument-type #'vector cl-vector)
-;;  (let ((cl-i (length cl-string))
-;;	cl-char cl-other)
-;;    (when (= cl-i (length cl-vector))
-;;      (while (and (>= (setq cl-i (1- cl-i)) 0)
-;;		  (or (eq (setq cl-char (aref cl-string cl-i))
-;;			  (setq cl-other (aref cl-vector cl-i)))
-;;		      (and (characterp cl-other) ; Note we want to call this
-;;						 ; as rarely as possible, it
-;;						 ; doesn't have a bytecode.
-;;			   (eq (downcase cl-char) (downcase cl-other))))))
-;;      (< cl-i 0))))
-;;
-;;;; See comment on cl-string-vector-equalp above.
-;;(defsubst cl-bit-vector-vector-equalp (cl-bit-vector cl-vector)
-;;  "Helper function for `equalp', which see."
-;;;  (check-argument-type #'bit-vector-p cl-bit-vector)
-;;;  (check-argument-type #'vectorp cl-vector)
-;;  (let ((cl-i (length cl-bit-vector))
-;;	cl-other)
-;;    (when (= cl-i (length cl-vector))
-;;      (while (and (>= (setq cl-i (1- cl-i)) 0)
-;;		  (numberp (setq cl-other (aref cl-vector cl-i)))
-;;		  ;; Differs from clisp here.
-;;		  (= (aref cl-bit-vector cl-i) cl-other)))
-;;      (< cl-i 0))))
-;;
-;;;; These two helper functions call equalp recursively, the two above have no
-;;;; need to.
-;;(defsubst cl-vector-array-equalp (cl-vector cl-array)
-;;  "Helper function for `equalp', which see."
-;;;  (check-argument-type #'vector cl-vector)
-;;;  (check-argument-type #'arrayp cl-array)
-;;  (let ((cl-i (length cl-vector)))
-;;    (when (= cl-i (length cl-array))
-;;      (while (and (>= (setq cl-i (1- cl-i)) 0)
-;;		  (equalp (aref cl-vector cl-i) (aref cl-array cl-i))))
-;;      (< cl-i 0))))
-;;
-;;(defsubst cl-hash-table-contents-equalp (cl-hash-table-1 cl-hash-table-2)
-;;  "Helper function for `equalp', which see."
-;;  (symbol-macrolet
-;;      ;; If someone has gone and fished the uninterned symbol out of this
-;;      ;; function's constants vector, and subsequently stored it as a value
-;;      ;; in a hash table, it's their own damn fault when
-;;      ;; `cl-hash-table-contents-equalp' gives the wrong answer.
-;;      ((equalp-default '#:equalp-default))
-;;    (loop
-;;      for x-key being the hash-key in cl-hash-table-1
-;;      using (hash-value x-value)
-;;      with y-value = nil
-;;      always (and (not (eq equalp-default
-;;			   (setq y-value (gethash x-key cl-hash-table-2
-;;						  equalp-default))))
-;;		  (equalp y-value x-value)))))
-;;
-;;(defun equalp (x y)
-;;  "Return t if two Lisp objects have similar structures and contents.
-;;
-;;This is like `equal', except that it accepts numerically equal
-;;numbers of different types (float, integer, bignum, bigfloat), and also
-;;compares strings and characters case-insensitively.
-;;
-;;Arrays (that is, strings, bit-vectors, and vectors) of the same length and
-;;with contents that are `equalp' are themselves `equalp'.
-;;
-;;Two hash tables are `equalp' if they have the same test (see
-;;`hash-table-test'), if they have the same number of entries, and if, for
-;;each entry in one hash table, its key is equivalent to a key in the other
-;;hash table using the hash table test, and its value is `equalp' to the other
-;;hash table's value for that key."
-;;  (cond ((eq x y))
-;;	((stringp x)
-;;	 (if (stringp y)
-;;	     (eq t (compare-strings x nil nil y nil nil t))
-;;	   (if (vectorp y)
-;;	       (cl-string-vector-equalp x y)
-;;	     ;; bit-vectors and strings are only equalp if they're
-;;	     ;; zero-length:
-;;	     (and (equal "" x) (equal #* y)))))
-;;	((numberp x)
-;;	 (and (numberp y) (= x y)))
-;;	((consp x)
-;;	 (while (and (consp x) (consp y) (equalp (car x) (car y)))
-;;	   (setq x (cdr x) y (cdr y)))
-;;	 (and (not (consp x)) (equalp x y)))
-;;	(t
-;;	 ;; From here on, the type tests don't (yet) have bytecodes.
-;;	 (let ((x-type (type-of x)))
-;;	   (cond ((eq 'vector x-type)
-;;		  (if (stringp y)
-;;		      (cl-string-vector-equalp y x)
-;;		    (if (vectorp y)
-;;			(cl-vector-array-equalp x y)
-;;		      (if (bit-vector-p y)
-;;			  (cl-bit-vector-vector-equalp y x)))))
-;;		 ((eq 'character x-type)
-;;		  (and (characterp y)
-;;		       ;; If the characters are actually identical, the
-;;		       ;; first eq test will have caught them above; we only
-;;		       ;; need to check them case-insensitively here.
-;;		       (eq (downcase x) (downcase y))))
-;;		 ((eq 'hash-table x-type)
-;;		  (and (hash-table-p y)
-;;		       (eq (hash-table-test x) (hash-table-test y))
-;;		       (= (hash-table-count x) (hash-table-count y))
-;;		       (cl-hash-table-contents-equalp x y)))
-;;		 ((eq 'bit-vector x-type)
-;;		  (if (bit-vector-p y)
-;;		      (equal x y)
-;;		    (if (vectorp y)
-;;			(cl-bit-vector-vector-equalp x y)
-;;		      ;; bit-vectors and strings are only equalp if they're
-;;		      ;; zero-length:
-;;		      (and (equal "" y) (equal #* x)))))
-;;		 (t (equal x y)))))))
 ;; XEmacs; #'map, #'mapc, #'mapl, #'maplist, #'mapcon, #'some and #'every
 ;; are now in C, together with #'map-into, which was never in this file.
 (defun notany (cl-pred cl-seq &rest cl-rest)
 (if (consp (car cl-progv-save))
 	(set (car (car cl-progv-save)) (cdr (car cl-progv-save)))
 (makunbound (car cl-progv-save)))
 (pop cl-progv-save)))
 ;;; Numbers.
 (defun gcd (&rest args)
 "Return the greatest common divisor of the arguments."
 (let ((a (abs (or (pop args) 0))))
 	    g2)
 	(while (< (setq g2 (/ (+ g (/ a g)) 2)) g)
 	  (setq g g2))
 	g)
 (if (eq a 0) 0 (signal 'arith-error nil))))
-;; XEmacs addition
-(defun cl-expt (x y)
-"Return X raised to the power of Y.  Works only for integer arguments."
-(if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0))
-(* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2)))))
-(or (and (fboundp 'expt) (subrp (symbol-function 'expt)))
-(defalias 'expt 'cl-expt))
 ;; We can't use macrolet in this file; whence the literal macro
 ;; definition-and-call:
 ((macro . (lambda (&rest symbols)
 "Make some old CL package truncate and round functions available.
 (defun cl-finite-do (func a b)
 (condition-case nil
 (let ((res (funcall func a b)))   ; check for IEEE infinity
 	(and (numberp res) (/= res (/ res 2)) res))
 (arith-error nil)))
-(defvar most-positive-float)
-(defvar most-negative-float)
-(defvar least-positive-float)
-(defvar least-negative-float)
-(defvar least-positive-normalized-float)
-(defvar least-negative-normalized-float)
-(defvar float-epsilon)
-(defvar float-negative-epsilon)
 (defun cl-float-limits ()
 (or most-positive-float (not (numberp '2e1))
 (let ((x '2e0) y z)
 	;; Find maximum exponent (first two loops are optimizations)
 	(setq x '1e0)
 	(while (/= (- '1e0 x) '1e0) (setq x (/ x 2)))
 	(setq float-negative-epsilon (* x 2))))
 nil)
+;; XEmacs; call cl-float-limits at dump time.
+(cl-float-limits)
 ;;; Sequence functions.
-;XEmacs -- our built-in is more powerful.
+;; XEmacs; #'subseq is in C.
-;(defun subseq (seq start &optional end)
-;  "Return the subsequence of SEQ from START to END.
-;If END is omitted, it defaults to the length of the sequence.
-;If START or END is negative, it counts from the end."
-;  (if (stringp seq) (substring seq start end)
-;    (let (len)
-;      (and end (< end 0) (setq end (+ end (setq len (length seq)))))
-;      (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
-;      (cond ((listp seq)
-;	     (if (> start 0) (setq seq (nthcdr start seq)))
-;	     (if end
-;		 (let ((res nil))
-;		   (while (>= (setq end (1- end)) start)
-;		     (push (pop seq) res))
-;		   (nreverse res))
-;	       (copy-sequence seq)))
-;	    (t
-;	     (or end (setq end (or len (length seq))))
-;	     (let ((res (make-vector (max (- end start) 0) nil))
-;		   (i 0))
-;	       (while (< start end)
-;		 (aset res i (aref seq start))
-;		 (setq i (1+ i) start (1+ start)))
-;	       res))))))
 (defun concatenate (type &rest seqs)
 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES."
 ;; XEmacs change: use case instead of cond for clarity
 (case type
 (vector (apply 'vconcat seqs))
 (string (apply 'concat seqs))
 (list   (apply 'append (append seqs '(nil))))
-(t (error "Not a sequence type name: %s" type))))
+(t (error 'invalid-argument "Not a sequence type name" type))))
 ;;; List functions.
 (defun revappend (x y)
 "Equivalent to (append (reverse X) Y)."
 (defun nreconc (x y)
 "Equivalent to (nconc (nreverse X) Y)."
 (nconc (nreverse x) y))
-(defun list-length (x)
+(defun list-length (list)
-"Return the length of a list.  Return nil if list is circular."
+"Return the length of LIST.  Return nil if LIST is circular."
-(let ((n 0) (fast x) (slow x))
+(if (listp list)
-(while (and (cdr fast) (not (and (eq fast slow) (> n 0))))
+(condition-case nil (length list) (circular-list))
-(setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow)))
+;; Error on not-a-list:
-(if fast (if (cdr fast) nil (1+ n)) n)))
+(car list)))
 (defun tailp (sublist list)
 "Return true if SUBLIST is a tail of LIST."
 (while (and (consp list) (not (eq sublist list)))
 (setq list (cdr list)))
 (if (numberp sublist) (equal sublist list) (eq sublist list)))
 (defalias 'cl-copy-tree 'copy-tree)
 ;;; Property lists.
 ;; XEmacs: our `get' groks DEFAULT.
 (defalias 'get* 'get)
 				   (and (not full) '((block) (eval-when)))))
 (message "Formatting...")
 (prog1 (cl-prettyprint form)
 (message ""))))
 (run-hooks 'cl-extra-load-hook)
 ;; XEmacs addition
 (provide 'cl-extra)

Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 5219:2d0937dc83cf