;;; cl-extra.el --- Common Lisp extensions for XEmacs Lisp (part two)

;; Copyright (C) 1993,2000,2003  Free Software Foundation, Inc.
;; Copyright (C) 2002 Ben Wing.

;; Author: Dave Gillespie <daveg@synaptics.com>
;; Maintainer: XEmacs Development Team
;; Version: 2.02
;; Keywords: extensions, dumped

;; This file is part of XEmacs.

;; XEmacs 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 of the License, or (at your
;; option) any later version.

;; XEmacs is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
;; for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Synched up with: FSF 21.3.

;;; Commentary:

;; This file is dumped with XEmacs.

;; These are extensions to Emacs Lisp that provide a degree of
;; 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.
;;
;; Bug reports, comments, and suggestions are welcome!

;; This file contains portions of the Common Lisp extensions
;; package which are autoloaded since they are relatively obscure.

;; See cl.el for Change Log.


;;; Code:

;;; Type coercion.

(defun coerce (object type)
  "Coerce OBJECT to type TYPE.
TYPE is a Common Lisp type specifier."
  (cond ((eq type 'list) (if (listp object) object (append object nil)))
	((eq type 'vector) (if (vectorp object) object (vconcat object)))
	((eq type 'string) (if (stringp object) object (concat object)))
	((eq type 'array) (if (arrayp object) object (vconcat object)))
	((and (eq type 'character) (stringp object)
	      (eql (length object) 1)) (aref object 0))
	((and (eq type 'character) (symbolp object))
	 (coerce (symbol-name object) type))
	;; XEmacs addition character <-> integer coercions
	((and (eq type 'character) (char-int-p object)) (int-char object))
	((and (memq type '(integer fixnum)) (characterp object))
	 (char-int object))
	((eq type 'float) (float object))
	;; XEmacs addition: enhanced numeric type coercions
	((and-fboundp 'coerce-number
	   (memq type '(integer ratio bigfloat fixnum))
	   (coerce-number object type)))
	;; XEmacs addition: bit-vector coercion
	((or (eq type 'bit-vector)
	     (eq type 'simple-bit-vector))
	 (if (bit-vector-p object)
	     object
	   (apply 'bit-vector (append object nil))))
	;; XEmacs addition: weak-list coercion
	((eq type 'weak-list)
	 (if (weak-list-p object) object
	   (let ((wl (make-weak-list)))
	     (set-weak-list-list wl (if (listp object)
					object
				      (append object nil)))
	     wl)))
	((and
	  (memq (car-safe type) '(vector simple-array))
	  (loop
	    for (ignore elements length) = type
	    initially (declare (special ignore))
	    return (if (or (memq length '(* nil)) (eql length (length object)))
		       (cond
			((memq elements '(t * nil))
			 (coerce object 'vector))
			((memq elements '(string-char character))
			 (coerce object 'string))
			((eq elements 'bit)
			 (coerce object 'bit-vector)))
		     (error 
		      'wrong-type-argument
		      "Type specifier length must equal sequence length"
		      type)))))
	((eq (car-safe type) 'simple-vector)
	 (coerce object (list* 'vector t (cdr type))))
	((memq (car-safe type)
	       '(string simple-string base-string simple-base-string))
	 (coerce object (list* 'vector 'character (cdr type))))
	((eq (car-safe type) 'bit-vector)
	 (coerce object (list* 'vector 'bit (cdr type))))
	((typep object type) object)
	(t (error 'invalid-operation
		  "Can't coerce object to type" object type))))

;; XEmacs; #'equalp is in C.

;; XEmacs; #'map, #'mapc, #'mapl, #'maplist, #'mapcon, #'some and #'every
;; are now in C, together with #'map-into, which was never in this file.

;; The compiler macro for this in cl-macs.el means if #'complement is handed
;; a constant expression, byte-compiled code will see a byte-compiled
;; function.
(defun complement (function &optional documentation)
  "Return a function which gives the logical inverse of what FUNCTION would."
  `(lambda (&rest arguments) ,@(if documentation (list documentation))
     (not (apply ',function arguments))))

(defun notany (cl-predicate cl-seq &rest cl-rest)
  "Return true if PREDICATE is false of every element of SEQUENCE.

With optional SEQUENCES, call PREDICATE each time with as many arguments as
there are SEQUENCES (plus one for the element from SEQUENCE).

arguments: (PREDICATE SEQUENCES &rest SEQUENCES)"
  (not (apply 'some cl-predicate cl-seq cl-rest)))

(defun notevery (cl-predicate cl-seq &rest cl-rest)
  "Return true if PREDICATE is false of some element of SEQUENCE.

With optional SEQUENCES, call PREDICATE each time with as many arguments as
there are SEQUENCES (plus one for the element from SEQUENCE).

arguments: (PREDICATE SEQUENCES &rest SEQUENCES)"
  (not (apply 'every cl-predicate cl-seq cl-rest)))

;;; Support for `loop'.
(defalias 'cl-map-keymap 'map-keymap)

(defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
  (or cl-base
      (setq cl-base (copy-sequence [0])))
  (map-keymap
   (function
    (lambda (cl-key cl-bind)
      (aset cl-base (1- (length cl-base)) cl-key)
      (if (keymapp cl-bind)
	  (cl-map-keymap-recursively
	   cl-func-rec cl-bind
	   (vconcat cl-base (list 0)))
	(funcall cl-func-rec cl-base cl-bind))))
   cl-map))

(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
  (or cl-what (setq cl-what (current-buffer)))
  (if (bufferp cl-what)
      (let (cl-mark cl-mark2 (cl-next t) cl-next2)
	(with-current-buffer cl-what
	  (setq cl-mark (copy-marker (or cl-start (point-min))))
	  (setq cl-mark2 (and cl-end (copy-marker cl-end))))
	(while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2)))
	  (setq cl-next (if cl-prop (next-single-property-change
				     cl-mark cl-prop cl-what)
			  (next-property-change cl-mark cl-what))
		cl-next2 (or cl-next (with-current-buffer cl-what
				       (point-max))))
	  (funcall cl-func (prog1 (marker-position cl-mark)
			     (set-marker cl-mark cl-next2))
		   (if cl-mark2 (min cl-next2 cl-mark2) cl-next2)))
	(set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))
    (or cl-start (setq cl-start 0))
    (or cl-end (setq cl-end (length cl-what)))
    (while (< cl-start cl-end)
      (let ((cl-next (or (if cl-prop (next-single-property-change
				      cl-start cl-prop cl-what)
			   (next-property-change cl-start cl-what))
			 cl-end)))
	(funcall cl-func cl-start (min cl-next cl-end))
	(setq cl-start cl-next)))))

(defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
  (or cl-buffer (setq cl-buffer (current-buffer)))
  (with-fboundp '(overlay-start overlay-end overlays-at next-overlay-change)
    (if-fboundp 'overlay-lists

	;; This is the preferred algorithm, though overlay-lists is
	;; undocumented.
	(let (cl-ovl)
	  (with-current-buffer cl-buffer
	    (setq cl-ovl (overlay-lists))
	    (if cl-start (setq cl-start (copy-marker cl-start)))
	    (if cl-end (setq cl-end (copy-marker cl-end))))
	  (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl)))
	  (while (and cl-ovl
		      (or (not (overlay-start (car cl-ovl)))
			  (and cl-end (>= (overlay-start (car cl-ovl)) cl-end))
			  (and cl-start (<= (overlay-end (car cl-ovl))
					    cl-start))
			  (not (funcall cl-func (car cl-ovl) cl-arg))))
	    (setq cl-ovl (cdr cl-ovl)))
	  (if cl-start (set-marker cl-start nil))
	  (if cl-end (set-marker cl-end nil)))

      ;; This alternate algorithm fails to find zero-length overlays.
      (let ((cl-mark (with-current-buffer cl-buffer
		       (copy-marker (or cl-start (point-min)))))
	    (cl-mark2 (and cl-end (with-current-buffer cl-buffer
				    (copy-marker cl-end))))
	    cl-pos cl-ovl)
	(while (save-excursion
		 (and (setq cl-pos (marker-position cl-mark))
		      (< cl-pos (or cl-mark2 (point-max)))
		      (progn
			(set-buffer cl-buffer)
			(setq cl-ovl (overlays-at cl-pos))
			(set-marker cl-mark (next-overlay-change cl-pos)))))
	  (while (and cl-ovl
		      (or (/= (overlay-start (car cl-ovl)) cl-pos)
			  (not (and (funcall cl-func (car cl-ovl) cl-arg)
				    (set-marker cl-mark nil)))))
	    (setq cl-ovl (cdr cl-ovl))))
	(set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))))))

;;; Support for `setf'.
(defun cl-set-frame-visible-p (frame val)
  (cond ((null val) (make-frame-invisible frame))
	((eq val 'icon) (iconify-frame frame))
	(t (make-frame-visible frame)))
  val)

;;; Support for `progv'.
(defvar cl-progv-save)
(defun cl-progv-before (syms values)
  (while syms
    (push (if (boundp (car syms))
		 (cons (car syms) (symbol-value (car syms)))
	       (car syms)) cl-progv-save)
    (if values
	(set (pop syms) (pop values))
      (makunbound (pop syms)))))

(defun cl-progv-after ()
  (while cl-progv-save
    (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))))
    (while args
      (let ((b (abs (pop args))))
	(while (> b 0) (setq b (% a (setq a b))))))
    a))

(defun lcm (&rest args)
  "Return the least common multiple of the arguments."
  (if (memq 0 args)
      0
    (let ((a (abs (or (pop args) 1))))
      (while args
	(let ((b (abs (pop args))))
	  (setq a (* (/ a (gcd a b)) b))))
      a)))

(defun isqrt (a)
  "Return the integer square root of the argument."
  (if (and (integerp a) (> a 0))
      ;; XEmacs change
      (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000)
		     ((>= a 100) 100) (t 10)))
	    g2)
	(while (< (setq g2 (/ (+ g (/ a g)) 2)) g)
	  (setq g g2))
	g)
    (if (eq a 0) 0 (signal 'arith-error nil))))

;; 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.

These functions are now implemented in C; their Lisp implementations in this
XEmacs are trivial, so we provide them and mark them obsolete."
   (let (symbol result)
     (while symbols
       (setq symbol (car symbols)
	     symbols (cdr symbols))
       (push `(make-obsolete ',(intern (format "%s*" symbol))
	       ',symbol "21.5.29")
	     result)
       (push
	`(defun ,(intern (format "%s*" symbol)) (number &optional divisor)
	  ,(format "See `%s'. This returns a list, not multiple values."
		   symbol)
	  (multiple-value-list (,symbol number divisor)))
	result))
     (cons 'progn result))))
 ceiling floor round truncate)

(defun mod* (x y)
  "The remainder of X divided by Y, with the same sign as Y."
  (nth-value 1 (floor x y)))

(defun rem* (x y)
  "The remainder of X divided by Y, with the same sign as X."
  (nth-value 1 (truncate x y)))

(defun signum (a)
  "Return 1 if A is positive, -1 if negative, 0 if zero."
  (cond ((> a 0) 1) ((< a 0) -1) (t 0)))

;; Random numbers.

(defvar *random-state*)
(defun random* (lim &optional state)
  "Return a random nonnegative number less than LIM, an integer or float.
Optional second arg STATE is a random-state object."
  (or state (setq state *random-state*))
  ;; Inspired by "ran3" from Numerical Recipes.  Additive congruential method.
  (let ((vec (aref state 3)))
    (if (integerp vec)
	(let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1))
	  (aset state 3 (setq vec (make-vector 55 nil)))
	  (aset vec 0 j)
	  (while (> (setq i (% (+ i 21) 55)) 0)
	    (aset vec i (setq j (prog1 k (setq k (- j k))))))
	  (while (< (setq i (1+ i)) 200) (random* 2 state))))
    (let* ((i (aset state 1 (% (1+ (aref state 1)) 55)))
	   (j (aset state 2 (% (1+ (aref state 2)) 55)))
	   (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
      (if (integerp lim)
	  (if (<= lim 512) (% n lim)
	    (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state))))
	    (let ((mask 1023))
	      (while (< mask (1- lim)) (setq mask (1+ (+ mask mask))))
	      (if (< (setq n (logand n mask)) lim) n (random* lim state))))
	(* (/ n '8388608e0) lim)))))

(defun make-random-state (&optional state)
  "Return a copy of random-state STATE, or of `*random-state*' if omitted.
If STATE is t, return a new state object seeded from the time of day."
  (cond ((null state) (make-random-state *random-state*))
	((vectorp state) (copy-tree state t))
	((integerp state) (vector 'cl-random-state-tag -1 30 state))
	(t (make-random-state (cl-random-time)))))

(defun random-state-p (object)
  "Return t if OBJECT is a random-state object."
  (and (vectorp object) (eql (length object) 4)
       (eq (aref object 0) 'cl-random-state-tag)))

;;; Sequence functions.

;; XEmacs; #'subseq, #'concatenate are in C.

;;; List functions.

(defun revappend (x y)
  "Equivalent to (append (reverse X) Y)."
  (nconc (reverse x) y))

(defun nreconc (x y)
  "Equivalent to (nconc (nreverse X) Y)."
  (nconc (nreverse x) y))

;; XEmacs; check LIST for type and circularity.
(defun tailp (sublist list)
  "Return true if SUBLIST is a tail of LIST."
  (check-argument-type #'listp list)
  (let ((before list) (evenp t))
    (while (and (consp list) (not (eq sublist list)))
      (setq list (cdr list)
	    evenp (not evenp))
      (if evenp (setq before (cdr before)))
      (if (eq before list) (error 'circular-list list)))
    (eql sublist list)))

(defalias 'cl-copy-tree 'copy-tree)

;;; Property lists.

;; XEmacs: our `get' groks DEFAULT.
(defalias 'get* 'get)
(defalias 'getf 'plist-get)

;; XEmacs; these are built-in.
(defalias 'cl-set-getf 'plist-put)
(defalias 'cl-do-remf 'plist-remprop)
(defalias 'cl-remprop 'remprop)

(defun get-properties (plist indicator-list)
  "Find a property from INDICATOR-LIST in PLIST.
Return 3 values:
- the first property found,
- its value,
- the tail of PLIST beginning with the found entry."
  (do ((plst plist (cddr plst)))
      ((null plst) (values nil nil nil))
    (cond ((atom (cdr plst))
	   (error "Malformed property list: %S." plist))
	  ((memq (car plst) indicator-list)
	   (return (values (car plst) (cadr plst) plst))))))

;; See also the compiler macro in cl-macs.el.
(defun constantly (value &rest more-values)
  "Construct a function always returning VALUE, and possibly MORE-VALUES.

The constructed function accepts any number of arguments, and ignores them.

Members of MORE-VALUES, if provided, will be passed as multiple values; see
`multiple-value-bind' and `multiple-value-setq'."
  (symbol-macrolet
      ((arglist '(&rest ignore)))
    (if (or more-values (eval-when-compile (not (cl-compiling-file))))
        `(lambda ,arglist (values-list ',(cons value more-values)))
      (make-byte-code
       arglist
       (eval-when-compile
         (let ((compiled (byte-compile-sexp #'(lambda (&rest ignore)
                                                (declare (ignore ignore))
                                                'placeholder))))
           (assert (and
                    (equal [placeholder]
                           (compiled-function-constants compiled))
                    (= 1 (compiled-function-stack-depth compiled)))
		   t
		   "Our assumptions about compiled code appear not to hold.")
           (compiled-function-instructions compiled)))
       (vector value) 1))))

;;; Hash tables. XEmacs; remove the compatibility stuff, which was all that
;;; remained here, given the hash table implementation is in C.

;;; Some debugging aids.

(defun cl-prettyprint (form)
  "Insert a pretty-printed rendition of a Lisp FORM in current buffer."
  (let ((pt (point)) last just)
    (insert "\n" (prin1-to-string form) "\n")
    (setq last (point))
    (goto-char (1+ pt))
    (while (re-search-forward "(\\(?:\\(?:function\\|quote\\) \\)" last t)
      (if (eql (length "(function ") (- (match-end 0) (match-beginning 0)))
          (replace-match "#'" t t)
        (replace-match "'" t t))
      (setq just (point))
      (forward-sexp)
      (delete-char 1)
      (goto-char just))
    (goto-char (1+ pt))
    (cl-do-prettyprint)))

(defun cl-do-prettyprint ()
  (skip-chars-forward " ")
  (if (looking-at "(")
      (let ((skip (or (looking-at "((")
		      ;; XEmacs: be selective about trailing stuff after prog
		      (looking-at
		       "(prog\\([nv12]\\|ress-feedback\\|n-with-message\\)")
		      (looking-at "(unwind-protect ")
		      (looking-at "(function (")
		      (looking-at "(cl-block-wrapper ")))
	    (two (or (looking-at "(defun ") (looking-at "(defmacro ")))
	    (let (or (looking-at "(let\\*? ") (looking-at "(while ")))
	    (set (looking-at "(p?set[qf] ")))
	(if (or skip let
		(progn
		  (forward-sexp)
		  (and (>= (current-column) 78) (progn (backward-sexp) t))))
	    (let ((nl t))
	      (forward-char 1)
	      (cl-do-prettyprint)
	      (or skip (looking-at ")") (cl-do-prettyprint))
	      (or (not two) (looking-at ")") (cl-do-prettyprint))
	      (while (not (looking-at ")"))
		(if set (setq nl (not nl)))
		(if nl (insert "\n"))
		(lisp-indent-line)
		(cl-do-prettyprint))
	      (forward-char 1))))
    (forward-sexp)))

(defvar cl-macroexpand-cmacs nil)
(defvar cl-closure-vars nil)

(defun cl-macroexpand-all (form &optional env)
  "Expand all macro calls through a Lisp FORM.
This also does some trivial optimizations to make the form prettier."
  (while (or (not (eq form (setq form (macroexpand form env))))
	     (and cl-macroexpand-cmacs
		  (not (eq form (setq form (compiler-macroexpand form)))))))
  (cond ((not (consp form)) form)
	((memq (car form) '(let let*))
	 (if (null (nth 1 form))
	     (cl-macroexpand-all (cons 'progn (cddr form)) env)
	   (let ((letf nil) (res nil) (lets (cadr form)) (env env) shadows)
	     (while lets
	       (push (funcall
                      #'(lambda (symbol valueform)
                          (let* ((eq-hash (eq-hash symbol))
                                 (acons (cdr (assoc* eq-hash env))))
                            (if (null acons)
                                ;; No symbol macro encountered.
                                (cons symbol
                                      (cl-macroexpand-body valueform env))
                              ;; OK, there is a symbol macro. Shadow it?
                              (if (cadr acons)
                                  (if (eq (car form) 'let*)
                                      ;; `let*' --> shadow immediately.
                                      (push `(,eq-hash . nil) env)
                                    ;; `let'; delay until all bindings
                                    ;; processed.
                                    (push `(,eq-hash . nil) shadows))
                                ;; Don't shadow it.
                                (setq symbol (car acons))
                                (unless (symbolp symbol) (setq letf t)))
                              (cons symbol
                                    (cl-macroexpand-body valueform env)))))
                      (if (consp (car lets)) (caar lets) (car lets))
                      (cdr-safe (car-safe lets)))
                     res)
	       (setq lets (cdr lets)))
	     (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form))
		    (nreverse res)
                    (cl-macroexpand-body (cddr form) (nconc shadows env))))))
	((eq (car form) 'cond)
	 (cons (car form)
	       (mapcar (function (lambda (x) (cl-macroexpand-body x env)))
		       (cdr form))))
	((eq (car form) 'condition-case)
	 (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env)
		(mapcar (function
			 (lambda (x)
			   (cons (car x) (cl-macroexpand-body (cdr x) env))))
			(cdddr form))))
	((memq (car form) '(quote function))
	 (if (eq (car-safe (nth 1 form)) 'lambda)
             (let* ((env
                     (reduce #'nconc (nth 1 (nth 1 form)) :from-end t
                             :key #'(lambda (symbol)
                                      (when (and
                                             (not (member
                                                   symbol
                                                   '(&optional &rest)))
                                             ;; Is there an existing symbol
                                             ;; macro?
                                             (cdr (assoc*
                                                   (setq symbol
                                                         (eq-hash symbol))
                                                   env)))
                                        ;; If so, shadow it by a nil symbol
                                        ;; macro, so there's no expansion, and
                                        ;; the variable is treated normally.
                                        `((,symbol . nil))))
                             :initial-value env))
                    (body (cl-macroexpand-body (cddadr form) env)))
	       (if (and cl-closure-vars (eq (car form) 'function)
			(cl-expr-contains-any body cl-closure-vars))
		   (let* ((closed (remove* nil cl-closure-vars :key
                                           #'(lambda (y)
                                               (cl-expr-contains body y))))
                          (new (mapcar 'gensym closed))
			  (sub (pairlis closed new)))
		     (put (car (last cl-closure-vars)) 'used t)
                     `(apply-partially #'(lambda ,(append new (cadadr form))
                                           ,@(sublis sub body))
                                       ,@closed))
		 (list (car form) (list* 'lambda (cadadr form) body))))
           ;; This is a bit of a hack; special-case symbols with bindings as
           ;; labels.
	   (let ((found (cdr (assq (cadr form) env))))
	     (cond
              ((and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
               ;; This is the implementation of labels in cl-macs.el.
               (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env))
              ((and (consp found) (eq (nth 1 (nth 1 found))
                                      'byte-compile-labels-args))
               ;; We're using the implementation of labels in
               ;; bytecomp.el. Quote its data-placeholder with FUNCTION so
               ;; that code can tell uses as data apart from the uses with
               ;; funcall.
               (unless (eq 'function (car form))
                 (byte-compile-warn
                  "deprecated: '%s, use #'%s instead to quote it as a function"
                  (cadr form) (cadr form)))
               (setq found (get (nth 1 (nth 1 (nth 3 found)))
                                'byte-compile-data-placeholder))
               (put found 'byte-compile-label-calls
                    (1+ (get found 'byte-compile-label-calls 0)))
               (list 'function found))
              (t form)))))
	((memq (car form) '(defun defmacro))
         (let ((env
                (reduce #'nconc (nth 2 form) :from-end t
                        :key #'(lambda (symbol)
                                 (when (and (not (member symbol
                                                         '(&optional &rest)))
                                            ;; Is there an existing symbol
                                            ;; macro?
                                            (cdr (assoc*
                                                  (setq symbol
                                                        (eq-hash symbol))
                                                  env)))
                                   ;; If so, shadow it by a nil symbol
                                   ;; macro, so there's no expansion, and
                                   ;; the variable is treated normally.
                                   `((,symbol . nil))))
                        :initial-value env)))
           (list* (car form) (nth 1 form)
                  (cl-macroexpand-body (cddr form) env))))
	((and (eq (car form) 'progn) (not (cddr form)))
	 (cl-macroexpand-all (nth 1 form) env))
	((eq (car form) 'setq)
	 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args))
	   (while (and p (symbolp (car p))) (setq p (cddr p)))
	   (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args))))
	(t (cons (car form) (cl-macroexpand-body (cdr form) env)))))

(defun cl-macroexpand-body (body &optional env)
  (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body))

(defun cl-prettyexpand (form &optional full)
  (message "Expanding...")
  (let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
	(byte-compile-macro-environment nil))
    (setq form (cl-macroexpand-all form
				   (and (not full)
                                        '((block) (return-from) (eval-when)))))
    (message "Formatting...")
    (prog1 (cl-prettyprint form)
      (message ""))))

;; XEmacs addition; force cl-macs to be available from here on when
;; compiling files to be dumped.  This is more reasonable than forcing other
;; files to do the same, multiple times.
(eval-when (:execute) (load "cl-macs"))

;; XEmacs, functions from Common Lisp.
(defun streamp (object)
  "Return non-nil if OBJECT is a stream.

This is something accepted as the OUTPUT-STREAM argument to `write-string' and
created with, e.g., `make-string-output-stream'.

This function returns nil for the symbols `t', `nil' or `standard-output',
despite that these values are accepted as the OUTPUT-STREAM argument to
`write-string'."
  (eq (type-of object) 'stream))

(defun* write-string (string &optional output-stream &key (start 0) end)
  "Output STRING to stream OUTPUT-STREAM.

OUTPUT-STREAM defaults to the value of `standard-output', which see.

Keywords :start and :end, if given, specify indices of a subsequence
of STRING to output.  They default to 0 and nil, meaning write the
entire string.

Returns STRING (not the subsequence of STRING that has been written to
OUTPUT-STREAM)."
  (check-type string string)
  (write-sequence string output-stream :start start :end end))

(defun* write-line (string &optional output-stream &key (start 0) end)
  "Output STRING, followed by a newline, to OUTPUT-STREAM.

STRING must be a string.  OUTPUT-STREAM defaults to the value of
`standard-output' (which see).

Keywords :start and :end, if given, specify indices of a subsequence
of STRING to output.  They default to 0 and nil, meaning write the
entire string.

Returns STRING (note, not the subsequence of STRING that has been written to
OUTPUT-STREAM)."
  (check-type string string)
  (prog1
      (write-sequence string output-stream :start start :end end)
    (terpri output-stream)))

(defun terpri (&optional stream)
  "Output a newline to STREAM.  Return t.
If STREAM is omitted or nil, the value of `standard-output' is used."
  (not (not (write-char ?\n stream))))

;; Implementation limits.

;; XEmacs; call cl-float-limits at dump time.
(labels
    ((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)))
     (cl-float-limits ()
       (unless most-positive-float 
	 (let ((x 2e0) y z)
	   ;; Find maximum exponent (first two loops are optimizations)
	   (while (cl-finite-do '* x x) (setq x (* x x)))
	   (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2))))
	   (while (cl-finite-do '+ x x) (setq x (+ x x)))
	   (setq z x y (/ x 2))
	   ;; Now fill in 1's in the mantissa.
	   (while (and (cl-finite-do '+ x y) (/= (+ x y) x))
	     (setq x (+ x y) y (/ y 2)))
	   (setq most-positive-float x
		 most-negative-float (- x))
	   ;; Divide down until mantissa starts rounding.
	   (setq x (/ x z) y (/ 16 z) x (* x y))
	   (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0))
		    (arith-error nil))
	     (setq x (/ x 2) y (/ y 2)))
	   (setq least-positive-normalized-float y
		 least-negative-normalized-float (- y))
	   ;; Divide down until value underflows to zero.
	   (setq x (/ 1 z) y x)
	   (while (condition-case nil (> (/ x 2) 0) (arith-error nil))
	     (setq x (/ x 2)))
	   (setq least-positive-float x
		 least-negative-float (- x))
	   (setq x 1e0)
	   (while (/= (+ 1e0 x) 1e0) (setq x (/ x 2)))
	   (setq float-epsilon (* x 2))
	   (setq x 1e0)
	   (while (/= (- 1e0 x) 1e0) (setq x (/ x 2)))
	   (setq float-negative-epsilon (* x 2))))))
  (cl-float-limits))


;;; Character functions.
(macrolet
    ((define-char-comparisons (&rest alist)
       "Provide Common Lisp's character-specific comparison predicates.

These throw errors if any arguments are non-characters, conflicting with
typical emacs behavior.  This is not the case if
`byte-compile-delete-errors' is non-nil; see the documentation of that
variable.

This doesn't include the case-insensitive comparisons, and it probably
should."
       (let* ((functions (mapcar 'car alist))
	      (map (mapcar #'(lambda (symbol)
			       `(,symbol .
				 ,(intern (substring (symbol-name symbol)
						     (length "char")))))
			   functions)))
	 `(progn
	   (mapc
	    (function*
	     (lambda ((function . cl-unsafe-comparison))
	       (put function 'cl-unsafe-comparison cl-unsafe-comparison)
	       (put function 'cl-compiler-macro
		    #'(lambda (form &rest arguments)
			(if byte-compile-delete-errors
			    (cons (get (car form) 'cl-unsafe-comparison)
				  (cdr form))
			  form)))))
	    ',map)
	   ,@(mapcar
	      (function*
	       (lambda ((function . documentation))
		 `(defun ,function (character &rest more-characters)
		   ,documentation
		   (check-type character character)
		   (check-type more-characters
			       (satisfies (lambda (list)
					    (every 'characterp list))))
		   (apply ',(cdr (assq function map))
			  character more-characters))))
	      alist)))))
  (define-char-comparisons
    (char= . "Return t if all character arguments are the same object.")
    (char/= . "Return t if no two character arguments are the same object.")
    (char< . "Return t if the character arguments monotonically increase.")
    (char> . "Return t if the character arguments monotonically decrease.")
    (char<= . "Return t if the character arguments are monotonically \
nondecreasing.")
    (char>= . "Return t if the character arguments are monotonically \
nonincreasing.")))

(defun alpha-char-p (character)
  "Return t if CHARACTER is alphabetic, in some alphabet.

Han characters are regarded as alphabetic."
  (check-type character character)
  (and (eql ?w (char-syntax character (standard-syntax-table)))
       (not (<= ?0 character ?9))))

(defun graphic-char-p (character)
  "Return t if CHARACTER is not a control character.

Control characters are those in the range ?\\x00 to ?\\x15 and ?\\x7f to
?\\x9f, inclusive."
  (check-type character character)
  (not (or (<= ?\x00 character ?\x1f) (<= ?\x7f character ?\x9f))))

(defun standard-char-p (character)
  "Return t if CHARACTER is one of Common Lisp's standard characters.

These are the non-control ASCII characters, plus the newline character."
  (check-type character character)
  (or (<= ?\x20 character ?\x7e) (eql character ?\n)))

(symbol-macrolet
    ((names '((?\x08 . "Backspace") (?\x09 . "Tab") (?\x0a . "Newline")
	      (?\x0C . "Page") (?\x0d . "Return") (?\x20 . "Space")
	      (?\x7f . "Rubout"))))

  (defun char-name (character)
    "Return a string naming CHARACTER.

For the limited number of characters where the character name has been
specified by Common Lisp, this always returns the appropriate string
name.  Otherwise, `char-name' requires that the Unicode database be
available; see `describe-char-unicode-data'."
    (check-type character character)
    (or (cdr (assq character names))
	(let ((unicode-data
	       (assoc "Name" (describe-char-unicode-data character))))
	  (and unicode-data
	       (if (string-match-p "^<[^>]+>$" (cadr unicode-data))
		   (format "U%04X" (char-to-unicode character))
		 (replace-in-string (cadr unicode-data) " " "_" t))))))

  (defun name-char (name)
    "Return a character with name NAME, a string."
    (or (car (rassoc* name names :test #'equalp))
	(if (string-match-p "^[uU][0-9A-Fa-f]+$" name)
	    (unicode-to-char (parse-integer name :start 1 :radix 16))
	  (with-current-buffer (get-buffer-create " *Unicode Data*")
	    (require 'descr-text)
	    (when (zerop (buffer-size))
	      ;; Don't use -literally in case of DOS line endings.
	      (insert-file-contents
               (declare-boundp describe-char-unicodedata-file)))
	    (goto-char (point-min))
	    (setq case-fold-search nil)
	    (and (re-search-forward (format #r"^\([0-9A-F]\{4,6\}\);%s;"
					    (upcase (replace-in-string
						     name "_" " " t))) nil t)
		 (unicode-to-char (parse-integer (match-string 1)
                                                 :radix 16))))))))

(defun upper-case-p (character)
  "Return t if CHARACTER is majuscule in the standard case table."
  (and (stringp character) (check-type character character))
  (with-case-table (standard-case-table)
    (not (eq character (downcase character)))))

(defun lower-case-p (character)
  "Return t if CHARACTER is minuscule in the standard case table."
  (and (stringp character) (check-type character character))
  (with-case-table (standard-case-table)
    (not (eq character (upcase character)))))

(defun both-case-p (character)
  "Return t if CHARACTER has case information in the standard case table."
  (and (stringp character) (check-type character character))
  (with-case-table (standard-case-table)
    (or (not (eq character (upcase character)))
	(not (eq character (downcase character))))))    

(defun char-upcase (character)
  "If CHARACTER is lowercase, return its corresponding uppercase character.
Otherwise, return CHARACTER."
  (and (stringp character) (check-type character character))
  (with-case-table (standard-case-table) (upcase character)))

(defun char-downcase (character)
  "If CHARACTER is uppercase, return its corresponding lowercase character.
Otherwise, return CHARACTER."
  (and (stringp character) (check-type character character))
  (with-case-table (standard-case-table) (downcase character)))

(defun integer-length (integer)
  "Return the number of bits need to represent INTEGER in two's complement.

Equivalent to `(ceiling (log (1+ integer) 2))' for positive integers, and
`(ceiling (log (- integer) 2))' for negative integers."
  (check-type integer integer)
  (when (< integer 0)
    ;; Don't use #'-, which fails silently with most-negative-fixnum.
    (setf integer (lognot integer)))
  (let ((count 0) (last integer))
    (while (not (eql (setq integer (/ integer 16)) 0))
      (setf last integer
            count (+ count 4)))
    (+ (aref (eval-when-compile
              (vconcat [0] (loop for fixnum from 1 below 16
                                 collect (length (format "%b" fixnum)))))
             last)
       count)))

(defun logcount (integer)
  "Return the number of one bits in INTEGER, if non-negative.

If INTEGER is negative, return the number of zero bits of lower order than the
most significant non-zero bit."
  (let ((integer (if (>= integer 0) integer (- (1+ integer))))
        (count 0))
    (while (not (eql 0 integer))
      (setf count
            (+ count (aref
                      (eval-when-compile
                       (vconcat
                        (loop for fixnum from 0 below 16
                              collect (count ?1 (format "%b" fixnum)))))
                      (% integer 16)))
            integer (/ integer 16)))
    count))

;; Type checking for the enhanced numeric types. These will all
;; appropriately give nil if the corresponding enhanced type is not
;; available in this XEmacs.

(defsubst* bignump (object)
  "Return t if OBJECT is a bignum, nil otherwise."
  (eq (type-of object) 'bignum))

(defsubst* ratiop (object)
  "Return t if OBJECT is a ratio, nil otherwise."
  (eq (type-of object) 'ratio))

(defsubst* rationalp (object)
  "Return t if OBJECT is a rational, nil otherwise."
  (and (member* (type-of object) '(fixnum bignum ratio)) t))

(defsubst* bigfloatp (object)
  "Return t if OBJECT is a bigfloat, nil otherwise."
  (eq (type-of object) 'bigfloat))

(defsubst* floatingp (object)
  "Return t if OBJECT is a floating point number of any kind, nil otherwise."
  (and (member* (type-of object) '(float bigfloat)) t))

(defsubst* realp (object)
  "Return t if OBJECT is a real, nil otherwise."
  (or (rationalp object) (floatingp object)))

;; These are here because labels and symbol-macrolet are not available in
;; obsolete.el. They are, however, all marked as obsolete in that file.
(symbol-macrolet ((not-nil '#:not-nil))
  (labels ((car-or-not-nil (object)
             (if (consp object) (car object) not-nil))
           (cdr-or-not-nil (object)
             (if (consp object) (cdr object) not-nil)))
    (defalias 'remassoc
      #'(lambda (key alist)
         (delete* key alist :test #'equal
                  :key (if key #'car-safe #'car-or-not-nil))))
    (defalias 'remrassoc
      #'(lambda (key alist)
         (delete* key alist :test #'equal
                  :key (if key #'cdr-safe #'cdr-or-not-nil))))
    (defalias 'remrassq
      #'(lambda (key alist)
         (delete* key alist :test #'eq
                  :key (if key #'cdr-safe #'cdr-or-not-nil))))
    (defalias 'remassq
      #'(lambda (key alist)
         (delete* key alist :test #'eq
                  :key (if key #'car-safe #'car-or-not-nil))))))

;; XEmacs; since cl-extra.el is dumped, cl-extra-load-hook is
;; useless. (Dumped files normally shouldn't be using hooks, functionality
;; should be implemented explicitly.)

;; XEmacs addition
(provide 'cl-extra)

;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed
;;; cl-extra.el ends here
