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

comparison lisp/cl-macs.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	15a9361e2781
children	13a418960a88

comparison

equal deleted inserted replaced

-:d93fedcbf6be
+:393039450288
 ;;; cl-macs.el --- Common Lisp extensions for XEmacs Lisp (part four)
-;; Copyright (C) 1993 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2003, 2004 Free Software Foundation, Inc.
 ;; Copyright (C) 2002 Ben Wing.
 ;; Author: Dave Gillespie <daveg@synaptics.com>
 ;; Version: 2.02
 ;; Keywords: extensions
 ;; 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:
 ;; 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.
 ;;
-;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19.
-;;
 ;; Bug reports, comments, and suggestions are welcome!
 ;; This file contains the portions of the Common Lisp extensions
 ;; package which should be autoloaded, but need only be present
 ;; if the compiler or interpreter is used---this file is not
 (or (memq 'cl-19 features)
 (error "Tried to load `cl-macs' before `cl'!"))
-;;; We define these here so that this file can compile without having
-;;; loaded the cl.el file already.
-(defmacro cl-push (x place) (list 'setq place (list 'cons x place)))
-(defmacro cl-pop (place)
-(list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))))
 (defmacro cl-pop2 (place)
 (list 'prog1 (list 'car (list 'cdr place))
 	(list 'setq place (list 'cdr (list 'cdr place)))))
-(put 'cl-push 'edebug-form-spec 'edebug-sexps)
-(put 'cl-pop 'edebug-form-spec 'edebug-sexps)
 (put 'cl-pop2 'edebug-form-spec 'edebug-sexps)
-(defvar cl-emacs-type)
 (defvar cl-optimize-safety)
 (defvar cl-optimize-speed)
 ;;; This kludge allows macros which use cl-transform-function-property
 ;;; to be called at compile-time.
 (require
 (progn
-(or (fboundp 'defalias) (fset 'defalias 'fset))
 (or (fboundp 'cl-transform-function-property)
 (defalias 'cl-transform-function-property
 	 #'(lambda (n p f)
 	     (list 'put (list 'quote n) (list 'quote p)
 		   (list 'function (cons 'lambda f))))))
 ;;; Initialization.
 (defvar cl-old-bc-file-form nil)
-;; Patch broken Emacs 18 compiler (re top-level macros).
-;; Emacs 19 compiler doesn't need this patch.
-;; Also, undo broken definition of `eql' that uses same bytecode as `eq'.
 ;;;###autoload
 (defun cl-compile-time-init ()
-(setq cl-old-bc-file-form (symbol-function 'byte-compile-file-form))
-(or (fboundp 'byte-compile-flush-pending)   ; Emacs 19 compiler?
-(defalias 'byte-compile-file-form
-	#'(lambda (form)
-	    (setq form (macroexpand form byte-compile-macro-environment))
-	    (if (eq (car-safe form) 'progn)
-		(cons 'progn (mapcar 'byte-compile-file-form (cdr form)))
-	      (funcall cl-old-bc-file-form form)))))
-(put 'eql 'byte-compile 'cl-byte-compile-compiler-macro)
 (run-hooks 'cl-hack-bytecomp-hook))
+;;; Some predicates for analyzing Lisp forms.  These are used by various
+;;; macro expanders to optimize the results in certain common cases.
+(defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
+			    car-safe cdr-safe progn prog1 prog2))
+(defconst cl-safe-funcs '(* / % length memq list vector vectorp
+			  < > <= >= = error))
+;;; Check if no side effects, and executes quickly.
+(defun cl-simple-expr-p (x &optional size)
+(or size (setq size 10))
+(if (and (consp x) (not (memq (car x) '(quote function function*))))
+(and (symbolp (car x))
+	   (or (memq (car x) cl-simple-funcs)
+	       (get (car x) 'side-effect-free))
+	   (progn
+	     (setq size (1- size))
+	     (while (and (setq x (cdr x))
+			 (setq size (cl-simple-expr-p (car x) size))))
+	     (and (null x) (>= size 0) size)))
+(and (> size 0) (1- size))))
+(defun cl-simple-exprs-p (xs)
+(while (and xs (cl-simple-expr-p (car xs)))
+(setq xs (cdr xs)))
+(not xs))
+;;; Check if no side effects.
+(defun cl-safe-expr-p (x)
+(or (not (and (consp x) (not (memq (car x) '(quote function function*)))))
+(and (symbolp (car x))
+	   (or (memq (car x) cl-simple-funcs)
+	       (memq (car x) cl-safe-funcs)
+	       (get (car x) 'side-effect-free))
+	   (progn
+	     (while (and (setq x (cdr x)) (cl-safe-expr-p (car x))))
+	     (null x)))))
+;;; Check if constant (i.e., no side effects or dependencies).
+(defun cl-const-expr-p (x)
+(cond ((consp x)
+	 (or (eq (car x) 'quote)
+	     (and (memq (car x) '(function function*))
+		  (or (symbolp (nth 1 x))
+		      (and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))
+	((symbolp x) (and (memq x '(nil t)) t))
+	(t t)))
+(defun cl-const-exprs-p (xs)
+(while (and xs (cl-const-expr-p (car xs)))
+(setq xs (cdr xs)))
+(not xs))
+(defun cl-const-expr-val (x)
+(and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
+(defun cl-expr-access-order (x v)
+(if (cl-const-expr-p x) v
+(if (consp x)
+	(progn
+	  (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v)))
+	  v)
+(if (eq x (car v)) (cdr v) '(t)))))
+;;; Count number of times X refers to Y.  Return nil for 0 times.
+(defun cl-expr-contains (x y)
+(cond ((equal y x) 1)
+	((and (consp x) (not (memq (car-safe x) '(quote function function*))))
+	 (let ((sum 0))
+	   (while x
+	     (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
+	   (and (> sum 0) sum)))
+	(t nil)))
+(defun cl-expr-contains-any (x y)
+(while (and y (not (cl-expr-contains x (car y)))) (pop y))
+y)
+;;; Check whether X may depend on any of the symbols in Y.
+(defun cl-expr-depends-p (x y)
+(and (not (cl-const-expr-p x))
+(or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y))))
+;;; Symbols.
+(defvar *gensym-counter*)
+;; XEmacs change: gensym and gentemp have been moved to cl.el.
 ;;; Program structure.
 ;;;###autoload
 	 ;; Do not upcase &optional, &key etc.
 	 (if (memq arg lambda-list-keywords) arg
 	   (intern (upcase (symbol-name arg)))))
 	((listp arg)
 	 (if (memq arg arglist-visited) (error 'circular-list '(arg)))
-	 (cl-push arg arglist-visited)
+	 (push arg arglist-visited)
 	 (let ((arg (copy-list arg)) junk)
 	   ;; Clean the list
 	   (let ((p (last arg))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
 	   (if (setq junk (cadr (memq '&cl-defs arg)))
 	       (setq arg (delq '&cl-defs (delq junk arg))))
 	 (header nil) (simple-args nil)
 (doc ""))
 ;; Add CL lambda list to documentation. npak@ispras.ru
 (if (and (stringp (car body))
 	     (cdr body))
-(setq doc (cl-pop body)))
+(setq doc (pop body)))
-(cl-push (concat doc
+(push (concat doc
-		     "\nCommon Lisp lambda list:\n"
+		  "\nCommon Lisp lambda list:\n"
-"  " (cl-function-arglist bind-block args)
+		  "  " (cl-function-arglist bind-block args)
-"\n\n")
+		  "\n\n")
-header)
+	  header)
 (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
-(cl-push (cl-pop body) header))
+(push (pop body) header))
 (setq args (if (listp args) (copy-list args) (list '&rest args)))
 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
 (if (setq bind-defs (cadr (memq '&cl-defs args)))
 	(setq args (delq '&cl-defs (delq bind-defs args))
 	      bind-defs (cadr bind-defs)))
 			      (list '&aux (list v 'cl-macro-environment))))))
 (while (and args (symbolp (car args))
 		(not (memq (car args) '(nil &rest &body &key &aux)))
 		(not (and (eq (car args) '&optional)
 			  (or bind-defs (consp (cadr args))))))
-(cl-push (cl-pop args) simple-args))
+(push (pop args) simple-args))
 (or (eq bind-block 'cl-none)
 	(setq body (list (list* 'block bind-block body))))
 (if (null args)
 	(list* nil (nreverse simple-args) (nconc (nreverse header) body))
-(if (memq '&optional simple-args) (cl-push '&optional args))
+(if (memq '&optional simple-args) (push '&optional args))
 (cl-do-arglist args nil (- (length simple-args)
 				 (if (memq '&optional simple-args) 1 0)))
 (setq bind-lets (nreverse bind-lets))
 (list* (and bind-inits (list* 'eval-when '(compile load eval)
 				    (nreverse bind-inits)))
 	     (nconc (nreverse simple-args)
-		    (list '&rest (car (cl-pop bind-lets))))
+		    (list '&rest (car (pop bind-lets))))
+	     ;; XEmacs change: we add usage information using Nickolay's
+	     ;; approach above
 	     (nconc (nreverse header)
 		    (list (nconc (list 'let* bind-lets)
 				 (nreverse bind-forms) body)))))))
 (defun cl-do-arglist (args expr &optional num)   ; uses bind-*
 (if (nlistp args)
 (if (or (memq args lambda-list-keywords) (not (symbolp args)))
 	  (error "Invalid argument name: %s" args)
-	(cl-push (list args expr) bind-lets))
+	(push (list args expr) bind-lets))
 (setq args (copy-list args))
 (let ((p (last args))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
 (let ((p (memq '&body args))) (if p (setcar p '&rest)))
 (if (memq '&environment args) (error "&environment used incorrectly"))
 (let ((save-args args)
 	  (laterarg nil) (exactarg nil) minarg)
 (or num (setq num 0))
 (if (listp (cadr restarg))
 	  (setq restarg (gensym "--rest--"))
 	(setq restarg (cadr restarg)))
-(cl-push (list restarg expr) bind-lets)
+(push (list restarg expr) bind-lets)
 (if (eq (car args) '&whole)
-	  (cl-push (list (cl-pop2 args) restarg) bind-lets))
+	  (push (list (cl-pop2 args) restarg) bind-lets))
 (let ((p args))
 	(setq minarg restarg)
 	(while (and p (not (memq (car p) lambda-list-keywords)))
 	  (or (eq p args) (setq minarg (list 'cdr minarg)))
 	  (setq p (cdr p)))
 		  exactarg (not (eq args p)))))
 (while (and args (not (memq (car args) lambda-list-keywords)))
 	(let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
 			    restarg)))
 	  (cl-do-arglist
-	   (cl-pop args)
+	   (pop args)
 	   (if (or laterarg (= safety 0)) poparg
 	     (list 'if minarg poparg
 		   (list 'signal '(quote wrong-number-of-arguments)
 			 (list 'list (and (not (eq bind-block 'cl-none))
 					  (list 'quote bind-block))
 			       (list 'length restarg)))))))
 	(setq num (1+ num) laterarg t))
-(while (and (eq (car args) '&optional) (cl-pop args))
+(while (and (eq (car args) '&optional) (pop args))
 	(while (and args (not (memq (car args) lambda-list-keywords)))
-	  (let ((arg (cl-pop args)))
+	  (let ((arg (pop args)))
 	    (or (consp arg) (setq arg (list arg)))
 	    (if (cddr arg) (cl-do-arglist (nth 2 arg) (list 'and restarg t)))
 	    (let ((def (if (cdr arg) (nth 1 arg)
 			 (or (car bind-defs)
 			     (nth 1 (assq (car arg) bind-defs)))))
 	      (setq num (1+ num))))))
 (if (eq (car args) '&rest)
 	  (let ((arg (cl-pop2 args)))
 	    (if (consp arg) (cl-do-arglist arg restarg)))
 	(or (eq (car args) '&key) (= safety 0) exactarg
-	    (cl-push (list 'if restarg
+	    (push (list 'if restarg
 			   (list 'signal '(quote wrong-number-of-arguments)
 				 (list 'list
 				       (and (not (eq bind-block 'cl-none))
 					    (list 'quote bind-block))
 				       (list '+ num (list 'length restarg)))))
 		     bind-forms)))
-(while (and (eq (car args) '&key) (cl-pop args))
+(while (and (eq (car args) '&key) (pop args))
 	(while (and args (not (memq (car args) lambda-list-keywords)))
-	  (let ((arg (cl-pop args)))
+	  (let ((arg (pop args)))
 	    (or (consp arg) (setq arg (list arg)))
 	    (let* ((karg (if (consp (car arg)) (caar arg)
 			   (intern (format ":%s" (car arg)))))
 		   (varg (if (consp (car arg)) (cadar arg) (car arg)))
 		   (def (if (cdr arg) (cadr arg)
 				     (if (eq (cl-const-expr-p def) t)
 					 (list
 					  'quote
 					  (list nil (cl-const-expr-val def)))
 				       (list 'list nil def))))))))
-	      (cl-push karg keys)
+	      (push karg keys)
+	      ;; XEmacs addition
 	      (if (= (aref (symbol-name karg) 0) ?:)
 		  (progn (set karg karg)
-			 (cl-push (list 'setq karg (list 'quote karg))
+			 (push (list 'setq karg (list 'quote karg))
-				  bind-inits)))))))
+			       bind-inits)))))))
 (setq keys (nreverse keys))
-(or (and (eq (car args) '&allow-other-keys) (cl-pop args))
+(or (and (eq (car args) '&allow-other-keys) (pop args))
 	  (null keys) (= safety 0)
 	  (let* ((var (gensym "--keys--"))
 		 (allow '(:allow-other-keys))
 		 (check (list
 			 'while var
 				(list
 				 'error
 				 (format "Keyword argument %%s not one of %s"
 					 keys)
 				 (list 'car var)))))))
-	    (cl-push (list 'let (list (list var restarg)) check) bind-forms)))
+	    (push (list 'let (list (list var restarg)) check) bind-forms)))
-(while (and (eq (car args) '&aux) (cl-pop args))
+(while (and (eq (car args) '&aux) (pop args))
 	(while (and args (not (memq (car args) lambda-list-keywords)))
 	  (if (consp (car args))
 	      (if (and bind-enquote (cadar args))
 		  (cl-do-arglist (caar args)
-				 (list 'quote (cadr (cl-pop args))))
+				 (list 'quote (cadr (pop args))))
-		(cl-do-arglist (caar args) (cadr (cl-pop args))))
+		(cl-do-arglist (caar args) (cadr (pop args))))
-	    (cl-do-arglist (cl-pop args) nil))))
+	    (cl-do-arglist (pop args) nil))))
 (if args (error "Malformed argument list %s" save-args)))))
 (defun cl-arglist-args (args)
 (if (nlistp args) (list args)
 (let ((res nil) (kind nil) arg)
 (while (consp args)
-	(setq arg (cl-pop args))
+	(setq arg (pop args))
 	(if (memq arg lambda-list-keywords) (setq kind arg)
-	  (if (eq arg '&cl-defs) (cl-pop args)
+	  (if (eq arg '&cl-defs) (pop args)
 	    (and (consp arg) kind (setq arg (car arg)))
 	    (and (consp arg) (cdr arg) (eq kind '&key) (setq arg (cadr arg)))
 	    (setq res (nconc res (cl-arglist-args arg))))))
 (nconc res (and args (list args))))))
 If `compile' is in WHEN, BODY is evaluated when compiled at top-level.
 If `load' is in WHEN, BODY is evaluated when loaded after top-level compile.
 If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level."
 (if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
 	   (not cl-not-toplevel) (not (boundp 'for-effect)))  ; horrible kludge
-(let ((comp (or (memq 'compile when) (memq ':compile-toplevel when)))
+(let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
 	    (cl-not-toplevel t))
-	(if (or (memq 'load when) (memq ':load-toplevel when))
+	(if (or (memq 'load when) (memq :load-toplevel when))
 	    (if comp (cons 'progn (mapcar 'cl-compile-time-too body))
 	      (list* 'if nil nil body))
 	  (progn (if comp (eval (cons 'progn body))) nil)))
-(and (or (memq 'eval when) (memq ':execute when))
+(and (or (memq 'eval when) (memq :execute when))
 	 (cons 'progn body))))
 (defun cl-compile-time-too (form)
 (or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
 (setq form (macroexpand
 		  form (cons '(eval-when) byte-compile-macro-environment))))
 (cond ((eq (car-safe form) 'progn)
 	 (cons 'progn (mapcar 'cl-compile-time-too (cdr form))))
 	((eq (car-safe form) 'eval-when)
 	 (let ((when (nth 1 form)))
-	   (if (or (memq 'eval when) (memq ':execute when))
+	   (if (or (memq 'eval when) (memq :execute when))
 	       (list* 'eval-when (cons 'compile when) (cddr form))
 	     form)))
 	(t (eval form) form)))
-(or (and (fboundp 'eval-when-compile)
-	 (not (eq (car-safe (symbol-function 'eval-when-compile)) 'autoload)))
-(eval '(defmacro eval-when-compile (&rest body)
-	     "Like `progn', but evaluates the body at compile time.
-The result of the body appears to the compiler as a quoted constant."
-	     (list 'quote (eval (cons 'progn body))))))
 ;;;###autoload
 (defmacro load-time-value (form &optional read-only)
 "Like `progn', but evaluates the body at load time.
 The result of the body appears to the compiler as a quoted constant."
 	 (body (cons
 		'cond
 		(mapcar
 		 #'(lambda (c)
 		     (cons (cond ((memq (car c) '(t otherwise))
+				  ;; XEmacs addition: check for last clause
 				  (or (eq c last-clause)
 				      (error
 				       "`%s' is allowed only as the last case clause"
 				       (car c)))
 				  t)
 				  (list 'member* temp (list 'quote (car c))))
 				 (t
 				  (if (memq (car c) head-list)
 				      (error "Duplicate key in case: %s"
 					     (car c)))
-				  (cl-push (car c) head-list)
+				  (push (car c) head-list)
 				  (list 'eql temp (list 'quote (car c)))))
 			   (or (cdr c) '(nil))))
 		 clauses))))
 (if (eq temp expr) body
 (list 'let (list (list temp expr)) body))))
 ;;;###autoload
 (defmacro ecase (expr &rest clauses)
 "(ecase EXPR CLAUSES...): like `case', but error if no case fits.
 `otherwise'-clauses are not allowed."
+;; XEmacs addition: disallow t and otherwise
 (let ((disallowed (or (assq t clauses)
 			(assq 'otherwise clauses))))
 (if disallowed
 	(error "`%s' is not allowed in ecase" (car disallowed))))
 (list* 'case expr (append clauses '((ecase-error-flag)))))
 		     (cons (cond ((eq (car c) 'otherwise) t)
 				 ((eq (car c) 'ecase-error-flag)
 				  (list 'error "etypecase failed: %s, %s"
 					temp (list 'quote (reverse type-list))))
 				 (t
-				  (cl-push (car c) type-list)
+				  (push (car c) type-list)
 				  (cl-make-type-test temp (car c))))
 			   (or (cdr c) '(nil))))
 		 clauses))))
 (if (eq temp expr) body
 (list 'let (list (list temp expr)) body))))
 (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
 (if cl-found (setcdr cl-found t)))
 (byte-compile-normal-call (cons 'throw (cdr cl-form))))
 ;;;###autoload
-(defmacro return (&optional res)
+(defmacro return (&optional result)
 "(return [RESULT]): return from the block named nil.
 This is equivalent to `(return-from nil RESULT)'."
-(list 'return-from nil res))
+(list 'return-from nil result))
 ;;;###autoload
-(defmacro return-from (name &optional res)
+(defmacro return-from (name &optional result)
 "(return-from NAME [RESULT]): return from the block named NAME.
 This jumps out to the innermost enclosing `(block NAME ...)' form,
 returning RESULT from that form (or nil if RESULT is omitted).
 This is compatible with Common Lisp, but note that `defun' and
 `defmacro' do not create implicit blocks as they do in Common Lisp."
 (let ((name2 (intern (format "--cl-block-%s--" name))))
-(list 'cl-block-throw (list 'quote name2) res)))
+(list 'cl-block-throw (list 'quote name2) result)))
 ;;; The "loop" macro.
 (defvar args) (defvar loop-accum-var) (defvar loop-accum-vars)
 	  (loop-map-form nil)   (loop-first-flag nil)
 	  (loop-destr-temps nil) (loop-symbol-macs nil))
 (setq args (append args '(cl-end-loop)))
 (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
 (if loop-finish-flag
-	  (cl-push (list (list loop-finish-flag t)) loop-bindings))
+	  (push (list (list loop-finish-flag t)) loop-bindings))
 (if loop-first-flag
-	  (progn (cl-push (list (list loop-first-flag t)) loop-bindings)
+	  (progn (push (list (list loop-first-flag t)) loop-bindings)
-		 (cl-push (list 'setq loop-first-flag nil) loop-steps)))
+		 (push (list 'setq loop-first-flag nil) loop-steps)))
 (let* ((epilogue (nconc (nreverse loop-finally)
 			      (list (or loop-result-explicit loop-result))))
 	     (ands (cl-loop-build-ands (nreverse loop-body)))
 	     (while-body (nconc (cadr ands) (nreverse loop-steps)))
 	     (body (append
 			    (list (list 'if loop-finish-flag
 					loop-result-var loop-result-var))
 			  (list (list 'if loop-finish-flag
 				      (cons 'progn epilogue) loop-result-var)))
 		      epilogue))))
-	(if loop-result-var (cl-push (list loop-result-var) loop-bindings))
+	(if loop-result-var (push (list loop-result-var) loop-bindings))
 	(while loop-bindings
 	  (if (cdar loop-bindings)
-	      (setq body (list (cl-loop-let (cl-pop loop-bindings) body t)))
+	      (setq body (list (cl-loop-let (pop loop-bindings) body t)))
 	    (let ((lets nil))
 	      (while (and loop-bindings
 			  (not (cdar loop-bindings)))
-		(cl-push (car (cl-pop loop-bindings)) lets))
+		(push (car (pop loop-bindings)) lets))
 	      (setq body (list (cl-loop-let lets body nil))))))
 	(if loop-symbol-macs
 	    (setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
 	(list* 'block loop-name body)))))
 (defun cl-parse-loop-clause ()   ; uses args, loop-*
-(let ((word (cl-pop args))
+(let ((word (pop args))
 	(hash-types '(hash-key hash-keys hash-value hash-values))
 	(key-types '(key-code key-codes key-seq key-seqs
 		     key-binding key-bindings)))
 (cond
 ((null args)
 (error "Malformed `loop' macro"))
 ((eq word 'named)
-(setq loop-name (cl-pop args)))
+(setq loop-name (pop args)))
 ((eq word 'initially)
-(if (memq (car args) '(do doing)) (cl-pop args))
+(if (memq (car args) '(do doing)) (pop args))
 (or (consp (car args)) (error "Syntax error on `initially' clause"))
 (while (consp (car args))
-	(cl-push (cl-pop args) loop-initially)))
+	(push (pop args) loop-initially)))
 ((eq word 'finally)
 (if (eq (car args) 'return)
 	  (setq loop-result-explicit (or (cl-pop2 args) '(quote nil)))
-	(if (memq (car args) '(do doing)) (cl-pop args))
+	(if (memq (car args) '(do doing)) (pop args))
 	(or (consp (car args)) (error "Syntax error on `finally' clause"))
 	(if (and (eq (caar args) 'return) (null loop-name))
-	    (setq loop-result-explicit (or (nth 1 (cl-pop args)) '(quote nil)))
+	    (setq loop-result-explicit (or (nth 1 (pop args)) '(quote nil)))
 	  (while (consp (car args))
-	    (cl-push (cl-pop args) loop-finally)))))
+	    (push (pop args) loop-finally)))))
 ((memq word '(for as))
 (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
 	    (ands nil))
 	(while
-	    (let ((var (or (cl-pop args) (gensym))))
+	    (let ((var (or (pop args) (gensym))))
-	      (setq word (cl-pop args))
+	      (setq word (pop args))
-	      (if (eq word 'being) (setq word (cl-pop args)))
+	      (if (eq word 'being) (setq word (pop args)))
-	      (if (memq word '(the each)) (setq word (cl-pop args)))
+	      (if (memq word '(the each)) (setq word (pop args)))
 	      (if (memq word '(buffer buffers))
 		  (setq word 'in args (cons '(buffer-list) args)))
 	      (cond
 	       ((memq word '(from downfrom upfrom to downto upto
 			     above below by))
-		(cl-push word args)
+		(push word args)
 		(if (memq (car args) '(downto above))
 		    (error "Must specify `from' value for downward loop"))
 		(let* ((down (or (eq (car args) 'downfrom)
 				 (memq (caddr args) '(downto above))))
 		       (excl (or (memq (car args) '(above below))
 		       (end-var (and (not (cl-const-expr-p end)) (gensym)))
 		       (step-var (and (not (cl-const-expr-p step))
 				      (gensym))))
 		  (and step (numberp step) (<= step 0)
 		       (error "Loop `by' value is not positive: %s" step))
-		  (cl-push (list var (or start 0)) loop-for-bindings)
+		  (push (list var (or start 0)) loop-for-bindings)
-		  (if end-var (cl-push (list end-var end) loop-for-bindings))
+		  (if end-var (push (list end-var end) loop-for-bindings))
-		  (if step-var (cl-push (list step-var step)
+		  (if step-var (push (list step-var step)
 					loop-for-bindings))
 		  (if end
-		      (cl-push (list
+		      (push (list
 				(if down (if excl '> '>=) (if excl '< '<=))
 				var (or end-var end)) loop-body))
-		  (cl-push (list var (list (if down '- '+) var
+		  (push (list var (list (if down '- '+) var
 					   (or step-var step 1)))
 			   loop-for-steps)))
 	       ((memq word '(in in-ref on))
 		(let* ((on (eq word 'on))
 		       (temp (if (and on (symbolp var)) var (gensym))))
-		  (cl-push (list temp (cl-pop args)) loop-for-bindings)
+		  (push (list temp (pop args)) loop-for-bindings)
-		  (cl-push (list 'consp temp) loop-body)
+		  (push (list 'consp temp) loop-body)
 		  (if (eq word 'in-ref)
-		      (cl-push (list var (list 'car temp)) loop-symbol-macs)
+		      (push (list var (list 'car temp)) loop-symbol-macs)
 		    (or (eq temp var)
 			(progn
-			  (cl-push (list var nil) loop-for-bindings)
+			  (push (list var nil) loop-for-bindings)
-			  (cl-push (list var (if on temp (list 'car temp)))
+			  (push (list var (if on temp (list 'car temp)))
 				   loop-for-sets))))
-		  (cl-push (list temp
+		  (push (list temp
 				 (if (eq (car args) 'by)
 				     (let ((step (cl-pop2 args)))
 				       (if (and (memq (car-safe step)
 						      '(quote function
 							      function*))
 					 (list 'funcall step temp)))
 				   (list 'cdr temp)))
 			   loop-for-steps)))
 	       ((eq word '=)
-		(let* ((start (cl-pop args))
+		(let* ((start (pop args))
 		       (then (if (eq (car args) 'then) (cl-pop2 args) start)))
-		  (cl-push (list var nil) loop-for-bindings)
+		  (push (list var nil) loop-for-bindings)
 		  (if (or ands (eq (car args) 'and))
 		      (progn
-			(cl-push (list var
+			(push (list var
 				       (list 'if
 					     (or loop-first-flag
 						 (setq loop-first-flag
 						       (gensym)))
 					     start var))
 				 loop-for-sets)
-			(cl-push (list var then) loop-for-steps))
+			(push (list var then) loop-for-steps))
-		    (cl-push (list var
+		    (push (list var
 				   (if (eq start then) start
 				     (list 'if
 					   (or loop-first-flag
 					       (setq loop-first-flag (gensym)))
 					   start then)))
 			     loop-for-sets))))
 	       ((memq word '(across across-ref))
 		(let ((temp-vec (gensym)) (temp-idx (gensym)))
-		  (cl-push (list temp-vec (cl-pop args)) loop-for-bindings)
+		  (push (list temp-vec (pop args)) loop-for-bindings)
-		  (cl-push (list temp-idx -1) loop-for-bindings)
+		  (push (list temp-idx -1) loop-for-bindings)
-		  (cl-push (list '< (list 'setq temp-idx (list '1+ temp-idx))
+		  (push (list '< (list 'setq temp-idx (list '1+ temp-idx))
 				 (list 'length temp-vec)) loop-body)
 		  (if (eq word 'across-ref)
-		      (cl-push (list var (list 'aref temp-vec temp-idx))
+		      (push (list var (list 'aref temp-vec temp-idx))
 			       loop-symbol-macs)
-		    (cl-push (list var nil) loop-for-bindings)
+		    (push (list var nil) loop-for-bindings)
-		    (cl-push (list var (list 'aref temp-vec temp-idx))
+		    (push (list var (list 'aref temp-vec temp-idx))
 			     loop-for-sets))))
 	       ((memq word '(element elements))
 		(let ((ref (or (memq (car args) '(in-ref of-ref))
 			       (and (not (memq (car args) '(in of)))
 				    (if (and (= (length (cadr args)) 2)
 					     (eq (caadr args) 'index))
 					(cadr (cl-pop2 args))
 				      (error "Bad `using' clause"))
 				  (gensym))))
-		  (cl-push (list temp-seq seq) loop-for-bindings)
+		  (push (list temp-seq seq) loop-for-bindings)
-		  (cl-push (list temp-idx 0) loop-for-bindings)
+		  (push (list temp-idx 0) loop-for-bindings)
 		  (if ref
 		      (let ((temp-len (gensym)))
-			(cl-push (list temp-len (list 'length temp-seq))
+			(push (list temp-len (list 'length temp-seq))
 				 loop-for-bindings)
-			(cl-push (list var (list 'elt temp-seq temp-idx))
+			(push (list var (list 'elt temp-seq temp-idx))
 				 loop-symbol-macs)
-			(cl-push (list '< temp-idx temp-len) loop-body))
+			(push (list '< temp-idx temp-len) loop-body))
-		    (cl-push (list var nil) loop-for-bindings)
+		    (push (list var nil) loop-for-bindings)
-		    (cl-push (list 'and temp-seq
+		    (push (list 'and temp-seq
 				   (list 'or (list 'consp temp-seq)
 					 (list '< temp-idx
 					       (list 'length temp-seq))))
 			     loop-body)
-		    (cl-push (list var (list 'if (list 'consp temp-seq)
+		    (push (list var (list 'if (list 'consp temp-seq)
 					     (list 'pop temp-seq)
 					     (list 'aref temp-seq temp-idx)))
 			     loop-for-sets))
-		  (cl-push (list temp-idx (list '1+ temp-idx))
+		  (push (list temp-idx (list '1+ temp-idx))
 			   loop-for-steps)))
 	       ((memq word hash-types)
 		(or (memq (car args) '(in of)) (error "Expected `of'"))
 		(let* ((table (cl-pop2 args))
 			  ((eq (car args) 'property)
 			   (setq prop (cl-pop2 args)))
 			  (t (setq buf (cl-pop2 args)))))
 		  (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
 		      (setq var1 (car var) var2 (cdr var))
-		    (cl-push (list var (list 'cons var1 var2)) loop-for-sets))
+		    (push (list var (list 'cons var1 var2)) loop-for-sets))
 		  (setq loop-map-form
 			(list 'cl-map-intervals
 			      (list 'function (list 'lambda (list var1 var2)
 						    '(progn . --cl-map)))
 			      buf prop from to))))
 						 key-types)
 					   (not (eq (caadr args) word)))
 				      (cadr (cl-pop2 args))
 				    (error "Bad `using' clause"))
 			       (gensym))))
+		  ;; XEmacs addition: track other-word
 		  (when (memq word '(key-binding key-bindings))
 		    (setq var (prog1 other (setq other var)))
 		    (and other-word (setq word other-word)))
 		  (setq loop-map-form
 			(list (if (memq word '(key-seq key-seqs))
-				  'cl-map-keymap-recursively 'cl-map-keymap)
+				  'cl-map-keymap-recursively 'map-keymap)
 			      (list 'function (list* 'lambda (list var other)
 						     '--cl-map)) map))))
 	       ((memq word '(frame frames screen screens))
 		(let ((temp (gensym)))
-		  (cl-push (list var '(selected-frame))
+		  (push (list var  '(selected-frame))
 			   loop-for-bindings)
-		  (cl-push (list temp nil) loop-for-bindings)
+		  (push (list temp nil) loop-for-bindings)
-		  (cl-push (list 'prog1 (list 'not (list 'eq var temp))
+		  (push (list 'prog1 (list 'not (list 'eq var temp))
 				 (list 'or temp (list 'setq temp var)))
 			   loop-body)
-		  (cl-push (list var (list 'next-frame var))
+		  (push (list var (list 'next-frame var))
 			   loop-for-steps)))
 	       ((memq word '(window windows))
 		(let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
 		      (temp (gensym)))
-		  (cl-push (list var (if scr
+		  (push (list var (if scr
 					 (list 'frame-selected-window scr)
 				       '(selected-window)))
 			   loop-for-bindings)
-		  (cl-push (list temp nil) loop-for-bindings)
+		  (push (list temp nil) loop-for-bindings)
-		  (cl-push (list 'prog1 (list 'not (list 'eq var temp))
+		  (push (list 'prog1 (list 'not (list 'eq var temp))
 				 (list 'or temp (list 'setq temp var)))
 			   loop-body)
-		  (cl-push (list var (list 'next-window var)) loop-for-steps)))
+		  (push (list var (list 'next-window var)) loop-for-steps)))
 	       (t
 		(let ((handler (and (symbolp word)
 				    (get word 'cl-loop-for-handler))))
 		  (if handler
 		      (funcall handler var)
 		    (error "Expected a `for' preposition, found %s" word)))))
 	      (eq (car args) 'and))
 	  (setq ands t)
-	  (cl-pop args))
+	  (pop args))
 	(if (and ands loop-for-bindings)
-	    (cl-push (nreverse loop-for-bindings) loop-bindings)
+	    (push (nreverse loop-for-bindings) loop-bindings)
 	  (setq loop-bindings (nconc (mapcar 'list loop-for-bindings)
 				     loop-bindings)))
 	(if loop-for-sets
-	    (cl-push (list 'progn
+	    (push (list 'progn
 			   (cl-loop-let (nreverse loop-for-sets) 'setq ands)
 			   t) loop-body))
 	(if loop-for-steps
-	    (cl-push (cons (if ands 'psetq 'setq)
+	    (push (cons (if ands 'psetq 'setq)
 			   (apply 'append (nreverse loop-for-steps)))
 		     loop-steps))))
 ((eq word 'repeat)
 (let ((temp (gensym)))
-	(cl-push (list (list temp (cl-pop args))) loop-bindings)
+	(push (list (list temp (pop args))) loop-bindings)
-	(cl-push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
+	(push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
-((eq word 'collect)
+((memq word '(collect collecting))
-(let ((what (cl-pop args))
+(let ((what (pop args))
 	    (var (cl-loop-handle-accum nil 'nreverse)))
 	(if (eq var loop-accum-var)
-	    (cl-push (list 'progn (list 'push what var) t) loop-body)
+	    (push (list 'progn (list 'push what var) t) loop-body)
-	  (cl-push (list 'progn
+	  (push (list 'progn
 			 (list 'setq var (list 'nconc var (list 'list what)))
 			 t) loop-body))))
 ((memq word '(nconc nconcing append appending))
-(let ((what (cl-pop args))
+(let ((what (pop args))
 	    (var (cl-loop-handle-accum nil 'nreverse)))
-	(cl-push (list 'progn
+	(push (list 'progn
 		       (list 'setq var
 			     (if (eq var loop-accum-var)
 				 (list 'nconc
 				       (list (if (memq word '(nconc nconcing))
 						 'nreverse 'reverse)
 			       (list (if (memq word '(nconc nconcing))
 					 'nconc 'append)
 				     var what))) t) loop-body)))
 ((memq word '(concat concating))
-(let ((what (cl-pop args))
+(let ((what (pop args))
 	    (var (cl-loop-handle-accum "")))
-	(cl-push (list 'progn (list 'callf 'concat var what) t) loop-body)))
+	(push (list 'progn (list 'callf 'concat var what) t) loop-body)))
 ((memq word '(vconcat vconcating))
-(let ((what (cl-pop args))
+(let ((what (pop args))
 	    (var (cl-loop-handle-accum [])))
-	(cl-push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))
+	(push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))
+;; XEmacs addition: handle bit-vectors
 ((memq word '(bvconcat bvconcating))
-(let ((what (cl-pop args))
+(let ((what (pop args))
 	    (var (cl-loop-handle-accum #*)))
-	(cl-push (list 'progn (list 'callf 'bvconcat var what) t) loop-body)))
+	(push (list 'progn (list 'callf 'bvconcat var what) t) loop-body)))
 ((memq word '(sum summing))
-(let ((what (cl-pop args))
+(let ((what (pop args))
 	    (var (cl-loop-handle-accum 0)))
-	(cl-push (list 'progn (list 'incf var what) t) loop-body)))
+	(push (list 'progn (list 'incf var what) t) loop-body)))
 ((memq word '(count counting))
-(let ((what (cl-pop args))
+(let ((what (pop args))
 	    (var (cl-loop-handle-accum 0)))
-	(cl-push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))
+	(push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))
 ((memq word '(minimize minimizing maximize maximizing))
-(let* ((what (cl-pop args))
+(let* ((what (pop args))
 	     (temp (if (cl-simple-expr-p what) what (gensym)))
 	     (var (cl-loop-handle-accum nil))
 	     (func (intern (substring (symbol-name word) 0 3)))
 	     (set (list 'setq var (list 'if var (list func var temp) temp))))
-	(cl-push (list 'progn (if (eq temp what) set
+	(push (list 'progn (if (eq temp what) set
 				(list 'let (list (list temp what)) set))
 		       t) loop-body)))
 ((eq word 'with)
 (let ((bindings nil))
-	(while (progn (cl-push (list (cl-pop args)
+	(while (progn (push (list (pop args)
 				     (and (eq (car args) '=) (cl-pop2 args)))
 			       bindings)
 		      (eq (car args) 'and))
-	  (cl-pop args))
+	  (pop args))
-	(cl-push (nreverse bindings) loop-bindings)))
+	(push (nreverse bindings) loop-bindings)))
 ((eq word 'while)
-(cl-push (cl-pop args) loop-body))
+(push (pop args) loop-body))
 ((eq word 'until)
-(cl-push (list 'not (cl-pop args)) loop-body))
+(push (list 'not (pop args)) loop-body))
 ((eq word 'always)
 (or loop-finish-flag (setq loop-finish-flag (gensym)))
-(cl-push (list 'setq loop-finish-flag (cl-pop args)) loop-body)
+(push (list 'setq loop-finish-flag (pop args)) loop-body)
 (setq loop-result t))
 ((eq word 'never)
 (or loop-finish-flag (setq loop-finish-flag (gensym)))
-(cl-push (list 'setq loop-finish-flag (list 'not (cl-pop args)))
+(push (list 'setq loop-finish-flag (list 'not (pop args)))
 	       loop-body)
 (setq loop-result t))
 ((eq word 'thereis)
 (or loop-finish-flag (setq loop-finish-flag (gensym)))
 (or loop-result-var (setq loop-result-var (gensym)))
-(cl-push (list 'setq loop-finish-flag
+(push (list 'setq loop-finish-flag
-		     (list 'not (list 'setq loop-result-var (cl-pop args))))
+		     (list 'not (list 'setq loop-result-var (pop args))))
 	       loop-body))
 ((memq word '(if when unless))
-(let* ((cond (cl-pop args))
+(let* ((cond (pop args))
 	     (then (let ((loop-body nil))
 		     (cl-parse-loop-clause)
 		     (cl-loop-build-ands (nreverse loop-body))))
 	     (else (let ((loop-body nil))
 		     (if (eq (car args) 'else)
-			 (progn (cl-pop args) (cl-parse-loop-clause)))
+			 (progn (pop args) (cl-parse-loop-clause)))
 		     (cl-loop-build-ands (nreverse loop-body))))
 	     (simple (and (eq (car then) t) (eq (car else) t))))
-	(if (eq (car args) 'end) (cl-pop args))
+	(if (eq (car args) 'end) (pop args))
 	(if (eq word 'unless) (setq then (prog1 else (setq else then))))
 	(let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
 			  (if simple (nth 1 else) (list (nth 2 else))))))
 	  (if (cl-expr-contains form 'it)
 	      (let ((temp (gensym)))
-		(cl-push (list temp) loop-bindings)
+		(push (list temp) loop-bindings)
 		(setq form (list* 'if (list 'setq temp cond)
 				  (subst temp 'it form))))
 	    (setq form (list* 'if cond form)))
-	  (cl-push (if simple (list 'progn form t) form) loop-body))))
+	  (push (if simple (list 'progn form t) form) loop-body))))
 ((memq word '(do doing))
 (let ((body nil))
 	(or (consp (car args)) (error "Syntax error on `do' clause"))
-	(while (consp (car args)) (cl-push (cl-pop args) body))
+	(while (consp (car args)) (push (pop args) body))
-	(cl-push (cons 'progn (nreverse (cons t body))) loop-body)))
+	(push (cons 'progn (nreverse (cons t body))) loop-body)))
 ((eq word 'return)
 (or loop-finish-flag (setq loop-finish-flag (gensym)))
 (or loop-result-var (setq loop-result-var (gensym)))
-(cl-push (list 'setq loop-result-var (cl-pop args)
+(push (list 'setq loop-result-var (pop args)
 		     loop-finish-flag nil) loop-body))
 (t
 (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
 	(or handler (error "Expected a loop keyword, found %s" word))
 	(funcall handler))))
 (if (eq (car args) 'and)
-	(progn (cl-pop args) (cl-parse-loop-clause)))))
+	(progn (pop args) (cl-parse-loop-clause)))))
 (defun cl-loop-let (specs body par)   ; uses loop-*
 (let ((p specs) (temps nil) (new nil))
 (while (and p (or (symbolp (car-safe (car p))) (null (cadar p))))
 (setq p (cdr p)))
 	 (progn
 	   (setq par nil p specs)
 	   (while p
 	     (or (cl-const-expr-p (cadar p))
 		 (let ((temp (gensym)))
-		   (cl-push (list temp (cadar p)) temps)
+		   (push (list temp (cadar p)) temps)
 		   (setcar (cdar p) temp)))
 	     (setq p (cdr p)))))
 (while specs
 (if (and (consp (car specs)) (listp (caar specs)))
 	  (let* ((spec (caar specs)) (nspecs nil)
-		 (expr (cadr (cl-pop specs)))
+		 (expr (cadr (pop specs)))
 		 (temp (cdr (or (assq spec loop-destr-temps)
-				(car (cl-push (cons spec (or (last spec 0)
+				(car (push (cons spec (or (last spec 0)
 							     (gensym)))
 					      loop-destr-temps))))))
-	    (cl-push (list temp expr) new)
+	    (push (list temp expr) new)
 	    (while (consp spec)
-	      (cl-push (list (cl-pop spec)
+	      (push (list (pop spec)
 			     (and expr (list (if spec 'pop 'car) temp)))
 		       nspecs))
 	    (setq specs (nconc (nreverse nspecs) specs)))
-	(cl-push (cl-pop specs) new)))
+	(push (pop specs) new)))
 (if (eq body 'setq)
 	(let ((set (cons (if par 'psetq 'setq) (apply 'nconc (nreverse new)))))
 	  (if temps (list 'let* (nreverse temps) set) set))
 (list* (if par 'let 'let*)
 	     (nconc (nreverse temps) (nreverse new)) body))))
 (defun cl-loop-handle-accum (def &optional func)   ; uses args, loop-*
 (if (eq (car args) 'into)
 (let ((var (cl-pop2 args)))
 	(or (memq var loop-accum-vars)
-	    (progn (cl-push (list (list var def)) loop-bindings)
+	    (progn (push (list (list var def)) loop-bindings)
-		   (cl-push var loop-accum-vars)))
+		   (push var loop-accum-vars)))
 	var)
 (or loop-accum-var
 	(progn
-	  (cl-push (list (list (setq loop-accum-var (gensym)) def))
+	  (push (list (list (setq loop-accum-var (gensym)) def))
 		   loop-bindings)
 	  (setq loop-result (if func (list func loop-accum-var)
 			      loop-accum-var))
 	  loop-accum-var))))
 					 (if (eq (car-safe (cadr clauses))
 						 'progn)
 					     (cdadr clauses)
 					   (list (cadr clauses))))
 				  (cddr clauses)))
-	    (setq body (cdr (butlast (cl-pop clauses)))))
+	    (setq body (cdr (butlast (pop clauses)))))
-	(cl-push (cl-pop clauses) ands)))
+	(push (pop clauses) ands)))
 (setq ands (or (nreverse ands) (list t)))
 (list (if (cdr ands) (cons 'and ands) (car ands))
 	  body
 	  (let ((full (if body
 			  (append ands (list (cons 'progn (append body '(t)))))
 	      (let ((func (list 'function*
 				(list 'lambda (cadr x)
 				      (list* 'block (car x) (cddr x))))))
 		(if (and (cl-compiling-file)
 			 (boundp 'byte-compile-function-environment))
-		    (cl-push (cons (car x) (eval func))
+		    (push (cons (car x) (eval func))
 			     byte-compile-function-environment))
 		(list (list 'symbol-function (list 'quote (car x))) func)))
 	  bindings)
 	 body))
 This is like `flet', except the bindings are lexical instead of dynamic.
 Unlike `flet', this macro is fully compliant with the Common Lisp standard."
 (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
 (while bindings
 (let ((var (gensym)))
-	(cl-push var vars)
+	(push var vars)
-	(cl-push (list 'function* (cons 'lambda (cdar bindings))) sets)
+	(push (list 'function* (cons 'lambda (cdar bindings))) sets)
-	(cl-push var sets)
+	(push var sets)
-	(cl-push (list (car (cl-pop bindings)) 'lambda '(&rest cl-labels-args)
+	(push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args)
 		       (list 'list* '(quote funcall) (list 'quote var)
 			     'cl-labels-args))
 		 cl-macro-environment)))
 (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body))
 			cl-macro-environment)))
 The main visible difference is that lambdas inside BODY will create
 lexical closures as in Common Lisp."
 (let* ((cl-closure-vars cl-closure-vars)
 	 (vars (mapcar #'(lambda (x)
 			   (or (consp x) (setq x (list x)))
-			   (cl-push (gensym (format "--%s--" (car x)))
+			   (push (gensym (format "--%s--" (car x)))
 				    cl-closure-vars)
+			   (set (car cl-closure-vars) [bad-lexical-ref])
 			   (list (car x) (cadr x) (car cl-closure-vars)))
 		       bindings))
 	 (ebody
 	  (cl-macroexpand-all
 	   (cons 'progn body)
 The main visible difference is that lambdas inside BODY will create
 lexical closures as in Common Lisp."
 (if (null bindings) (cons 'progn body)
 (setq bindings (reverse bindings))
 (while bindings
-(setq body (list (list* 'lexical-let (list (cl-pop bindings)) body))))
+(setq body (list (list* 'lexical-let (list (pop bindings)) body))))
 (car body)))
 (defun cl-defun-expander (func &rest rest)
 (list 'progn
 	(list 'defalias (list 'quote func)
 (cond ((null vars) (list 'progn form nil))
 	((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
 	(t
 	 (let* ((temp (gensym)) (n 0))
 	   (list 'let (list (list temp form))
-		 (list 'prog1 (list 'setq (cl-pop vars) (list 'car temp))
+		 (list 'prog1 (list 'setq (pop vars) (list 'car temp))
 		       (cons 'setq
 			     (apply 'nconc
 				    (mapcar
 				     #'(lambda (v)
 					 (list v (list
 (defvar cl-proclaim-history t)    ; for future compilers
 (defvar cl-declare-stack t)       ; for future compilers
 (defun cl-do-proclaim (spec hist)
-(and hist (listp cl-proclaim-history) (cl-push spec cl-proclaim-history))
+(and hist (listp cl-proclaim-history) (push spec cl-proclaim-history))
 (cond ((eq (car-safe spec) 'special)
 	 (if (boundp 'byte-compile-bound-variables)
 	     (setq byte-compile-bound-variables
 		   (append
+		    ;; XEmacs change
 		    (mapcar #'(lambda (v) (cons v byte-compile-global-bit))
 			    (cdr spec))
 		    byte-compile-bound-variables))))
 	((eq (car-safe spec) 'inline)
 nil)
 ;;; Process any proclamations made before cl-macs was loaded.
 (defvar cl-proclaims-deferred)
 (let ((p (reverse cl-proclaims-deferred)))
-(while p (cl-do-proclaim (cl-pop p) t))
+(while p (cl-do-proclaim (pop p) t))
 (setq cl-proclaims-deferred nil))
 ;;;###autoload
 (defmacro declare (&rest specs)
 (if (cl-compiling-file)
 (while specs
-	(if (listp cl-declare-stack) (cl-push (car specs) cl-declare-stack))
+	(if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
-	(cl-do-proclaim (cl-pop specs) nil)))
+	(cl-do-proclaim (pop specs) nil)))
 nil)
 ;;; Generalized variables.
 list, a store-variables list (of length one), a store-form, and an access-
 form.  See `defsetf' for a simpler way to define most setf-methods."
 (append '(eval-when (compile load eval))
 	  (if (stringp (car body))
 	      (list (list 'put (list 'quote func) '(quote setf-documentation)
-			  (cl-pop body))))
+			  (pop body))))
 	  (list (cl-transform-function-property
 		 func 'setf-method (cons args body)))))
+(defalias 'define-setf-expander 'define-setf-method)
 ;;;###autoload
 (defmacro defsetf (func arg1 &rest args)
 "(defsetf NAME FUNC): define a `setf' method.
 This macro is an easy-to-use substitute for `define-setf-method' that works
 	    (if (car args)
 		(list 'list '(quote progn) call 'store)
 	      call)))))
 ;;; Some standard place types from Common Lisp.
-(eval-when-compile (defvar ignored-arg)) ; Warning suppression
+(eval-when-compile (defvar ignored-arg)) ; XEmacs: warning suppression
 (defsetf aref aset)
 (defsetf car setcar)
 (defsetf cdr setcdr)
+(defsetf caar (x) (val) (list 'setcar (list 'car x) val))
+(defsetf cadr (x) (val) (list 'setcar (list 'cdr x) val))
+(defsetf cdar (x) (val) (list 'setcdr (list 'car x) val))
+(defsetf cddr (x) (val) (list 'setcdr (list 'cdr x) val))
 (defsetf elt (seq n) (store)
 (list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store)
 	(list 'aset seq n store)))
+;; XEmacs change: ignore the optional DEFAULT arguments
 (defsetf get (x y &optional ignored-arg) (store) (list 'put x y store))
 (defsetf get* (x y &optional ignored-arg) (store) (list 'put x y store))
-(defsetf gethash (x h &optional ignored-arg) (store) (list 'cl-puthash x store h))
+(defsetf gethash (x h &optional ignored-arg) (store) (list 'puthash x store h))
 (defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store))
 (defsetf subseq (seq start &optional end) (new)
-(list 'progn (list 'replace seq new ':start1 start ':end1 end) new))
+(list 'progn (list 'replace seq new :start1 start :end1 end) new))
 (defsetf symbol-function fset)
 (defsetf symbol-plist setplist)
 (defsetf symbol-value set)
 ;;; Various car/cdr aliases.  Note that `cadr' is handled specially.
 (defsetf tenth (x) (store) (list 'setcar (list 'nthcdr 9 x) store))
 (defsetf rest setcdr)
 ;;; Some more Emacs-related place types.
 (defsetf buffer-file-name set-visited-file-name t)
+;; XEmacs change: we do not need to wrap this in with-current-buffer
 (defsetf buffer-modified-p set-buffer-modified-p t)
 (defsetf buffer-name rename-buffer t)
 (defsetf buffer-string () (store)
 (list 'progn '(erase-buffer) (list 'insert store)))
 (defsetf buffer-substring cl-set-buffer-substring)
 (defsetf current-local-map use-local-map t)
 (defsetf current-window-configuration set-window-configuration t)
 (defsetf default-file-modes set-default-file-modes t)
 (defsetf default-value set-default)
 (defsetf documentation-property put)
+;;(defsetf extent-data set-extent-data)
 (defsetf extent-face set-extent-face)
 (defsetf extent-priority set-extent-priority)
+;; XEmacs addition
 (defsetf extent-property (x y &optional ignored-arg) (arg)
 (list 'set-extent-property x y arg))
+(defsetf extent-end-position (ext) (store)
+`(progn (set-extent-endpoints ,ext (extent-start-position ,ext) ,store)
+	  ,store))
 (defsetf extent-start-position (ext) (store)
 `(progn (set-extent-endpoints ,ext ,store (extent-end-position ,ext))
-	  ,store))
-(defsetf extent-end-position (ext) (store)
-`(progn (set-extent-endpoints ,ext (extent-start-position ,ext) ,store)
 	  ,store))
 (defsetf face-background (f &optional s) (x) (list 'set-face-background f x s))
 (defsetf face-background-pixmap (f &optional s) (x)
 (list 'set-face-background-pixmap f x s))
 (defsetf face-font (f &optional s) (x) (list 'set-face-font f x s))
 (defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s))
 (defsetf face-underline-p (f &optional s) (x)
 (list 'set-face-underline-p f x s))
 (defsetf file-modes set-file-modes t)
+(defsetf frame-height (&optional f) (v)
+`(progn (set-frame-height ,f ,v) ,v))
 (defsetf frame-parameters modify-frame-parameters t)
 (defsetf frame-visible-p cl-set-frame-visible-p)
+(defsetf frame-width (&optional f) (v)
+`(progn (set-frame-width ,f ,v) ,v))
+;; XEmacs change: frame-properties instead of frame-parameters
 (defsetf frame-properties (&optional f) (p)
 `(progn (set-frame-properties ,f ,p) ,p))
 (defsetf frame-property (f p &optional ignored-arg) (v)
 `(progn (set-frame-property ,f ,v) ,p))
-(defsetf frame-width (&optional f) (v)
+;; XEmacs addition
-`(progn (set-frame-width ,f ,v) ,v))
-(defsetf frame-height (&optional f) (v)
-`(progn (set-frame-height ,f ,v) ,v))
 (defsetf current-frame-configuration set-frame-configuration)
 ;; XEmacs: new stuff
 ;; Consoles
 (defsetf selected-console select-console t)
 ,v))
 (defsetf trunc-stack-length set-trunc-stack-length)
 (defsetf trunc-stack-stack set-trunc-stack-stack)
 (defsetf undoable-stack-max set-undoable-stack-max)
 (defsetf weak-list-list set-weak-list-list)
+;; End of new XEmacs stuff
 (defsetf getenv setenv t)
 (defsetf get-register set-register)
 (defsetf global-key-binding global-set-key)
 (defsetf keymap-parent set-keymap-parent)
+;; XEmacs addition: more keymap-related setf forms
 (defsetf keymap-name set-keymap-name)
 (defsetf keymap-prompt set-keymap-prompt)
 (defsetf keymap-default-binding set-keymap-default-binding)
 (defsetf local-key-binding local-set-key)
 (defsetf mark set-mark t)
 (defsetf point-min () (store)
 (list 'progn (list 'narrow-to-region store '(point-max)) store))
 (defsetf process-buffer set-process-buffer)
 (defsetf process-filter set-process-filter)
 (defsetf process-sentinel set-process-sentinel)
+;;(defsetf process-get process-put)
 (defsetf read-mouse-position (scr) (store)
 (list 'set-mouse-position scr (list 'car store) (list 'cdr store)))
+;;(defsetf screen-height set-screen-height t)
+;;(defsetf screen-width set-screen-width t)
 (defsetf selected-window select-window)
+;;(defsetf selected-screen select-screen)
 (defsetf selected-frame select-frame)
 (defsetf standard-case-table set-standard-case-table)
 (defsetf syntax-table set-syntax-table)
 (defsetf visited-file-modtime set-visited-file-modtime t)
 (defsetf window-buffer set-window-buffer t)
 				 (list 'cl-set-substring (nth 4 method)
 				       from-temp to-temp store-temp)))
 		(nth 3 method) store-temp)
 	  (list 'substring (nth 4 method) from-temp to-temp))))
+;; XEmacs addition
 (define-setf-method values (&rest args)
 (let ((methods (mapcar #'(lambda (x)
 			     (get-setf-method x cl-macro-environment))
 			 args))
 	(store-temp (gensym "--values-store--")))
 			    (cl-setf-simple-store-p (car (nth 2 method))
 						    (nth 3 method)))))
 	 (simple (and optimize (consp place) (cl-simple-exprs-p (cdr place)))))
 (while values
 (if (or simple (cl-const-expr-p (car values)))
-	  (cl-push (cons (cl-pop temps) (cl-pop values)) subs)
+	  (push (cons (pop temps) (pop values)) subs)
-	(cl-push (list (cl-pop temps) (cl-pop values)) lets)))
+	(push (list (pop temps) (pop values)) lets)))
 (list (nreverse lets)
 	  (cons (car (nth 2 method)) (sublis subs (nth 3 method)))
 	  (sublis subs (nth 4 method)))))
 (defun cl-setf-do-store (spec val)
 references such as (car x) or (aref x i), as well as plain symbols.
 For example, (setf (cadar x) y) is equivalent to (setcar (cdar x) y).
 The return value is the last VAL in the list."
 (if (cdr (cdr args))
 (let ((sets nil))
-	(while args (cl-push (list 'setf (cl-pop args) (cl-pop args)) sets))
+	(while args (push (list 'setf (pop args) (pop args)) sets))
 	(cons 'progn (nreverse sets)))
 (if (symbolp (car args))
 	(and args (cons 'setq args))
 (let* ((method (cl-setf-do-modify (car args) (nth 1 args)))
 	     (store (cl-setf-do-store (nth 1 method) (nth 1 args))))
 (while p
 (if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars))
 	  (setq simple nil))
 (if (memq (car p) vars)
 	  (error "Destination duplicated in psetf: %s" (car p)))
-(cl-push (cl-pop p) vars)
+(push (pop p) vars)
 (or p (error "Odd number of arguments to psetf"))
-(cl-pop p))
+(pop p))
 (if simple
 	(list 'progn (cons 'setf args) nil)
 (setq args (reverse args))
 (let ((expr (list 'setf (cadr args) (car args))))
 	(while (setq args (cddr args))
 ;;;###autoload
 (defmacro shiftf (place &rest args)
 "(shiftf PLACE PLACE... VAL): shift left among PLACEs.
 Example: (shiftf A B C) sets A to B, B to C, and returns the old A.
 Each PLACE may be a symbol, or any generalized variable allowed by `setf'."
+;; XEmacs change: use iteration instead of recursion
 (if (not (memq nil (mapcar 'symbolp (butlast (cons place args)))))
 (list* 'prog1 place
 	     (let ((sets nil))
 	       (while args
-		 (cl-push (list 'setq place (car args)) sets)
+		 (push (list 'setq place (car args)) sets)
-		 (setq place (cl-pop args)))
+		 (setq place (pop args)))
 	       (nreverse sets)))
 (let* ((places (reverse (cons place args)))
-	   (form (cl-pop places)))
+	   (form (pop places)))
 (while places
-	(let ((method (cl-setf-do-modify (cl-pop places) 'unsafe)))
+	(let ((method (cl-setf-do-modify (pop places) 'unsafe)))
 	  (setq form (list 'let* (car method)
 			   (list 'prog1 (nth 2 method)
 				 (cl-setf-do-store (nth 1 method) form))))))
 form)))
 (if (not (memq nil (mapcar 'symbolp args)))
 (and (cdr args)
 	   (let ((sets nil)
 		 (first (car args)))
 	     (while (cdr args)
-	       (setq sets (nconc sets (list (cl-pop args) (car args)))))
+	       (setq sets (nconc sets (list (pop args) (car args)))))
 	     (nconc (list 'psetf) sets (list (car args) first))))
 (let* ((places (reverse args))
 	   (temp (gensym "--rotatef--"))
 	   (form temp))
 (while (cdr places)
-	(let ((method (cl-setf-do-modify (cl-pop places) 'unsafe)))
+	(let ((method (cl-setf-do-modify (pop places) 'unsafe)))
 	  (setq form (list 'let* (car method)
 			   (list 'prog1 (nth 2 method)
 				 (cl-setf-do-store (nth 1 method) form))))))
 (let ((method (cl-setf-do-modify (car places) 'unsafe)))
 	(list 'let* (append (car method) (list (list temp (nth 2 method))))
 the PLACE is not modified before executing BODY."
 (if (null bindings)
 (cons 'progn body)
 (setq bindings (reverse bindings))
 (while bindings
-(setq body (list (list* 'letf (list (cl-pop bindings)) body))))
+(setq body (list (list* 'letf (list (pop bindings)) body))))
 (car body)))
 ;;;###autoload
 (defmacro callf (func place &rest args)
 "(callf FUNC PLACE ARGS...): set PLACE to (FUNC PLACE ARGS...).
 	 (type nil)
 	 (named nil)
 	 (forms nil)
 	 pred-form pred-check)
 (if (stringp (car descs))
-	(cl-push (list 'put (list 'quote name) '(quote structure-documentation)
+	(push (list 'put (list 'quote name) '(quote structure-documentation)
-		       (cl-pop descs)) forms))
+		       (pop descs)) forms))
 (setq descs (cons '(cl-tag-slot)
 		      (mapcar #'(lambda (x) (if (consp x) x (list x)))
 			      descs)))
 (while opts
 (let ((opt (if (consp (car opts)) (caar opts) (car opts)))
-	    (args (cdr-safe (cl-pop opts))))
+	    (args (cdr-safe (pop opts))))
-	(cond ((eq opt ':conc-name)
+	(cond ((eq opt :conc-name)
 	       (if args
 		   (setq conc-name (if (car args)
 				       (symbol-name (car args)) ""))))
-	      ((eq opt ':constructor)
+	      ((eq opt :constructor)
 	       (if (cdr args)
-		   (cl-push args constrs)
+		   (push args constrs)
 		 (if args (setq constructor (car args)))))
-	      ((eq opt ':copier)
+	      ((eq opt :copier)
 	       (if args (setq copier (car args))))
-	      ((eq opt ':predicate)
+	      ((eq opt :predicate)
 	       (if args (setq predicate (car args))))
-	      ((eq opt ':include)
+	      ((eq opt :include)
 	       (setq include (car args)
 		     include-descs (mapcar #'(lambda (x)
 					       (if (consp x) x (list x)))
 					   (cdr args))))
-	      ((eq opt ':print-function)
+	      ((eq opt :print-function)
 	       (setq print-func (car args)))
-	      ((eq opt ':type)
+	      ((eq opt :type)
 	       (setq type (car args)))
-	      ((eq opt ':named)
+	      ((eq opt :named)
 	       (setq named t))
-	      ((eq opt ':initial-offset)
+	      ((eq opt :initial-offset)
 	       (setq descs (nconc (make-list (car args) '(cl-skip-slot))
 				  descs)))
 	      (t
 	       (error "Slot option %s unrecognized" opt)))))
 (if print-func
 	  (while include-descs
 	    (setcar (memq (or (assq (caar include-descs) old-descs)
 			      (error "No slot %s in included struct %s"
 				     (caar include-descs) include))
 			  old-descs)
-		    (cl-pop include-descs)))
+		    (pop include-descs)))
 	  (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
 		type (car inc-type)
 		named (assq 'cl-tag-slot descs))
 	  (if (cadr inc-type) (setq tag name named t))
 	  (let ((incl include))
 	    (while incl
-	      (cl-push (list 'pushnew (list 'quote tag)
+	      (push (list 'pushnew (list 'quote tag)
 			     (intern (format "cl-struct-%s-tags" incl)))
 		       forms)
 	      (setq incl (get incl 'cl-struct-include)))))
 (if type
 	  (progn
 	    (or (memq type '(vector list))
 		(error "Illegal :type specifier: %s" type))
 	    (if named (setq tag name)))
 	(setq type 'vector named 'true)))
 (or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
-(cl-push (list 'defvar tag-symbol) forms)
+(push (list 'defvar tag-symbol) forms)
 (setq pred-form (and named
 			 (let ((pos (- (length descs)
 				       (length (memq (assq 'cl-tag-slot descs)
 						     descs)))))
 			   (if (eq type 'vector)
 			  (if (and (eq (caadr pred-form) 'vectorp)
 				   (= safety 1))
 			      (cons 'and (cdddr pred-form)) pred-form)))
 (let ((pos 0) (descp descs))
 (while descp
-	(let* ((desc (cl-pop descp))
+	(let* ((desc (pop descp))
 	       (slot (car desc)))
 	  (if (memq slot '(cl-tag-slot cl-skip-slot))
 	      (progn
-		(cl-push nil slots)
+		(push nil slots)
-		(cl-push (and (eq slot 'cl-tag-slot) (list 'quote tag))
+		(push (and (eq slot 'cl-tag-slot) (list 'quote tag))
 			 defaults))
 	    (if (assq slot descp)
 		(error "Duplicate slots named %s in %s" slot name))
 	    (let ((accessor (intern (format "%s%s" conc-name slot))))
-	      (cl-push slot slots)
+	      (push slot slots)
-	      (cl-push (nth 1 desc) defaults)
+	      (push (nth 1 desc) defaults)
-	      (cl-push (list*
+	      (push (list*
 			'defsubst* accessor '(cl-x)
 			(append
 			 (and pred-check
 			      (list (list 'or pred-check
 					  (list 'error
 							accessor name)
 						'cl-x))))
 			 (list (if (eq type 'vector) (list 'aref 'cl-x pos)
 				 (if (= pos 0) '(car cl-x)
 				   (list 'nth pos 'cl-x)))))) forms)
-	      (cl-push (cons accessor t) side-eff)
+	      (push (cons accessor t) side-eff)
-	      (cl-push (list 'define-setf-method accessor '(cl-x)
+	      (push (list 'define-setf-method accessor '(cl-x)
-			     (if (cadr (memq ':read-only (cddr desc)))
+			     (if (cadr (memq :read-only (cddr desc)))
 				 (list 'error (format "%s is a read-only slot"
 						      accessor))
 			       (list 'cl-struct-setf-expander 'cl-x
 				     (list 'quote name) (list 'quote accessor)
 				     (and pred-check (list 'quote pred-check))
 			       (list 'prin1 (list accessor 'cl-x) 'cl-s)))))))
 	(setq pos (1+ pos))))
 (setq slots (nreverse slots)
 	  defaults (nreverse defaults))
 (and predicate pred-form
-	 (progn (cl-push (list 'defsubst* predicate '(cl-x)
+	 (progn (push (list 'defsubst* predicate '(cl-x)
 			       (if (eq (car pred-form) 'and)
 				   (append pred-form '(t))
 				 (list 'and pred-form t))) forms)
-		(cl-push (cons predicate 'error-free) side-eff)))
+		(push (cons predicate 'error-free) side-eff)))
 (and copier
-	 (progn (cl-push (list 'defun copier '(x) '(copy-sequence x)) forms)
+	 (progn (push (list 'defun copier '(x) '(copy-sequence x)) forms)
-		(cl-push (cons copier t) side-eff)))
+		(push (cons copier t) side-eff)))
 (if constructor
-	(cl-push (list constructor
+	(push (list constructor
 		       (cons '&key (delq nil (copy-sequence slots))))
 		 constrs))
 (while constrs
 (let* ((name (caar constrs))
-	     (args (cadr (cl-pop constrs)))
+	     (args (cadr (pop constrs)))
 	     (anames (cl-arglist-args args))
 	     (make (mapcar* #'(lambda (s d) (if (memq s anames) s d))
 			    slots defaults)))
-	(cl-push (list 'defsubst* name
+	(push (list 'defsubst* name
 		       (list* '&cl-defs (list 'quote (cons nil descs)) args)
 		       (cons type make)) forms)
 	(if (cl-safe-expr-p (cons 'progn (mapcar 'second descs)))
-	    (cl-push (cons name t) side-eff))))
+	    (push (cons name t) side-eff))))
 (if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
 (if print-func
-	(cl-push (list 'push
+	(push (list 'push
 		       (list 'function
 			     (list 'lambda '(cl-x cl-s cl-n)
 				   (list 'and pred-form print-func)))
 		       'custom-print-functions) forms))
-(cl-push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)
+(push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)
-(cl-push (list* 'eval-when '(compile load eval)
+(push (list* 'eval-when '(compile load eval)
 		    (list 'put (list 'quote name) '(quote cl-struct-slots)
 			  (list 'quote descs))
 		    (list 'put (list 'quote name) '(quote cl-struct-type)
 			  (list 'quote (list type (eq named t))))
 		    (list 'put (list 'quote name) '(quote cl-struct-include)
 ;;; Types and assertions.
 ;;;###autoload
-(defmacro deftype (name args &rest body)
+(defmacro deftype (name arglist &rest body)
 "(deftype NAME ARGLIST BODY...): define NAME as a new data type.
 The type name can then be used in `typecase', `check-type', etc."
 (list 'eval-when '(compile load eval)
 	(cl-transform-function-property
-	 name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) args) body))))
+	 name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) arglist) body))))
 (defun cl-make-type-test (val type)
 (if (symbolp type)
 (cond ((get type 'cl-deftype-handler)
 	     (cl-make-type-test val (funcall (get type 'cl-deftype-handler))))
 	    ((memq type '(nil t)) type)
-	    ((eq type 'string-char) (list 'characterp val))
+	    ((eq type 'null) `(null ,val))
-	    ((eq type 'null) (list 'null val))
+	    ((eq type 'float) `(floatp-safe ,val))
-	    ((eq type 'float) (list 'floatp-safe val))
+	    ((eq type 'real) `(numberp ,val))
-	    ((eq type 'real) (list 'numberp val))
+	    ((eq type 'fixnum) `(integerp ,val))
-	    ((eq type 'fixnum) (list 'integerp val))
+	    ;; XEmacs change: we do not have char-valid-p
+	    ((memq type '(character string-char)) `(characterp ,val))
 	    (t
 	     (let* ((name (symbol-name type))
 		    (namep (intern (concat name "p"))))
 	       (if (fboundp namep) (list namep val)
 		 (list (intern (concat name "-p")) val)))))
 ;;;###autoload
 (defmacro check-type (place type &optional string)
 "Verify that PLACE is of type TYPE; signal a continuable error if not.
 STRING is an optional description of the desired type."
-(when (or (not (cl-compiling-file))
+(and (or (not (cl-compiling-file))
-	    (< cl-optimize-speed 3)
+	   (< cl-optimize-speed 3) (= cl-optimize-safety 3))
-	    (= cl-optimize-safety 3))
+(let* ((temp (if (cl-simple-expr-p place 3) place (gensym)))
-(let* ((temp (if (cl-simple-expr-p place 3) place (gensym)))
+	      (test (cl-make-type-test temp type))
-	   (test (cl-make-type-test temp type))
+	      (signal-error `(signal 'wrong-type-argument
-	   (signal-error `(signal 'wrong-type-argument
+			      ,(list 'list (or string (list 'quote type))
-				  ,(list 'list (or string (list 'quote type))
+				     temp (list 'quote place))))
-					 temp (list 'quote place))))
+	      (body
-	   (body
+	       (condition-case nil
-	    (condition-case nil
+		   `(while (not ,test)
-		`(while (not ,test)
+		     ,(macroexpand `(setf ,place ,signal-error)))
-		   ,(macroexpand `(setf ,place ,signal-error)))
+		 (error
-	      (error
+		  `(if ,test (progn ,signal-error nil))))))
-	       `(if ,test (progn ,signal-error nil))))))
+	 (if (eq temp place) `(progn ,body nil)
-(if (eq temp place)
+	   `(let ((,temp ,place)) ,body nil)))))
-	  body
-	`(let ((,temp ,place)) ,body)))))
 ;;;###autoload
 (defmacro assert (form &optional show-args string &rest args)
 "Verify that FORM returns non-nil; signal an error if not.
 Second arg SHOW-ARGS means to include arguments of FORM in message.
 			     (list* 'list (list 'quote form) sargs))))
 	       nil))))
 ;;;###autoload
 (defmacro ignore-errors (&rest body)
-"Execute FORMS; if an error occurs, return nil.
+"Execute BODY; if an error occurs, return nil.
-Otherwise, return result of last FORM."
+Otherwise, return result of last form in BODY."
 `(condition-case nil (progn ,@body) (error nil)))
+;; XEmacs addition
 ;;;###autoload
 (defmacro ignore-file-errors (&rest body)
 "Execute FORMS; if an error of type `file-error' occurs, return nil.
 Otherwise, return result of last FORM."
 `(condition-case nil (progn ,@body) (file-error nil)))
-;;; Some predicates for analyzing Lisp forms.  These are used by various
-;;; macro expanders to optimize the results in certain common cases.
-(defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
-			    car-safe cdr-safe progn prog1 prog2))
-(defconst cl-safe-funcs '(* / % length memq list vector vectorp
-			  < > <= >= = error))
-;;; Check if no side effects, and executes quickly.
-(defun cl-simple-expr-p (x &optional size)
-(or size (setq size 10))
-(if (and (consp x) (not (memq (car x) '(quote function function*))))
-(and (symbolp (car x))
-	   (or (memq (car x) cl-simple-funcs)
-	       (get (car x) 'side-effect-free))
-	   (progn
-	     (setq size (1- size))
-	     (while (and (setq x (cdr x))
-			 (setq size (cl-simple-expr-p (car x) size))))
-	     (and (null x) (>= size 0) size)))
-(and (> size 0) (1- size))))
-(defun cl-simple-exprs-p (xs)
-(while (and xs (cl-simple-expr-p (car xs)))
-(setq xs (cdr xs)))
-(not xs))
-;;; Check if no side effects.
-(defun cl-safe-expr-p (x)
-(or (not (and (consp x) (not (memq (car x) '(quote function function*)))))
-(and (symbolp (car x))
-	   (or (memq (car x) cl-simple-funcs)
-	       (memq (car x) cl-safe-funcs)
-	       (get (car x) 'side-effect-free))
-	   (progn
-	     (while (and (setq x (cdr x)) (cl-safe-expr-p (car x))))
-	     (null x)))))
-;;; Check if constant (i.e., no side effects or dependencies).
-(defun cl-const-expr-p (x)
-(cond ((consp x)
-	 (or (eq (car x) 'quote)
-	     (and (memq (car x) '(function function*))
-		  (or (symbolp (nth 1 x))
-		      (and (eq (car-safe (nth 1 x)) 'lambda) 'func)))))
-	((symbolp x) (and (memq x '(nil t)) t))
-	(t t)))
-(defun cl-const-exprs-p (xs)
-(while (and xs (cl-const-expr-p (car xs)))
-(setq xs (cdr xs)))
-(not xs))
-(defun cl-const-expr-val (x)
-(and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
-(defun cl-expr-access-order (x v)
-(if (cl-const-expr-p x) v
-(if (consp x)
-	(progn
-	  (while (setq x (cdr x)) (setq v (cl-expr-access-order (car x) v)))
-	  v)
-(if (eq x (car v)) (cdr v) '(t)))))
-;;; Count number of times X refers to Y.  Return NIL for 0 times.
-(defun cl-expr-contains (x y)
-(cond ((equal y x) 1)
-	((and (consp x) (not (memq (car-safe x) '(quote function function*))))
-	 (let ((sum 0))
-	   (while x
-	     (setq sum (+ sum (or (cl-expr-contains (cl-pop x) y) 0))))
-	   (and (> sum 0) sum)))
-	(t nil)))
-(defun cl-expr-contains-any (x y)
-(while (and y (not (cl-expr-contains x (car y)))) (cl-pop y))
-y)
-;;; Check whether X may depend on any of the symbols in Y.
-(defun cl-expr-depends-p (x y)
-(and (not (cl-const-expr-p x))
-(or (not (cl-safe-expr-p x)) (cl-expr-contains-any x y))))
 ;;; Compiler macros.
 ;;;###autoload
 compiler macros are expanded repeatedly until no further expansions are
 possible.  Unlike regular macros, BODY can decide to \"punt\" and leave the
 original function call alone by declaring an initial `&whole foo' parameter
 and then returning foo."
 (let ((p (if (listp args) args (list '&rest args))) (res nil))
-(while (consp p) (cl-push (cl-pop p) res))
+(while (consp p) (push (pop p) res))
-(setq args (nreverse res)) (setcdr res (and p (list '&rest p))))
+(setq args (nconc (nreverse res) (and p (list '&rest p)))))
 (list 'eval-when '(compile load eval)
 	(cl-transform-function-property
 	 func 'cl-compiler-macro
 	 (cons (if (memq '&whole args) (delq '&whole args)
 		 (cons '--cl-whole-arg-- args)) body))
 ARGLIST allows full Common Lisp conventions, and BODY is implicitly
 surrounded by (block NAME ...)."
 (let* ((argns (cl-arglist-args args)) (p argns)
 	 (pbody (cons 'progn body))
 	 (unsafe (not (cl-safe-expr-p pbody))))
-(while (and p (eq (cl-expr-contains args (car p)) 1)) (cl-pop p))
+(while (and p (eq (cl-expr-contains args (car p)) 1)) (pop p))
 (list 'progn
 	  (if p nil   ; give up if defaults refer to earlier args
 	    (list 'define-compiler-macro name
-		  (list* '&whole 'cl-whole '&cl-quote args)
+		  (if (memq '&key args)
+		      (list* '&whole 'cl-whole '&cl-quote args)
+		    (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)))
 			 (and (memq '&key args) 'cl-whole) unsafe argns)))
 	  (list* 'defun* name args body))))
 	       (list 'equal a b)
 	       (list 'eq a b)))
 	(t form)))
 (define-compiler-macro member* (&whole form a list &rest keys)
-(let ((test (and (= (length keys) 2) (eq (car keys) ':test)
+(let ((test (and (= (length keys) 2) (eq (car keys) :test)
 		   (cl-const-expr-val (nth 1 keys)))))
 (cond ((eq test 'eq) (list 'memq a list))
 	  ((eq test 'equal) (list 'member a list))
 	  ((or (null keys) (eq test 'eql))
 	   (if (eq (cl-const-expr-p a) t)
 		       (if (not mq) (list 'member a list) form))))
 	       form)))
 	  (t form))))
 (define-compiler-macro assoc* (&whole form a list &rest keys)
-(let ((test (and (= (length keys) 2) (eq (car keys) ':test)
+(let ((test (and (= (length keys) 2) (eq (car keys) :test)
 		   (cl-const-expr-val (nth 1 keys)))))
 (cond ((eq test 'eq) (list 'assq a list))
 	  ((eq test 'equal) (list 'assoc a list))
 	  ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql)))
 	   (if (floatp-safe (cl-const-expr-val a))
 	       (list 'assoc a list) (list 'assq a list)))
 	  (t form))))
 (define-compiler-macro adjoin (&whole form a list &rest keys)
 (if (and (cl-simple-expr-p a) (cl-simple-expr-p list)
-	   (not (memq ':key keys)))
+	   (not (memq :key keys)))
 (list 'if (list* 'member* a list keys) list (list 'cons a list))
 form))
 (define-compiler-macro list* (arg &rest others)
 (let* ((args (reverse (cons arg others)))
 	 (form (car args)))
 (while (setq args (cdr args))
 (setq form (list 'cons (car args) form)))
 form))
+;; XEmacs change: our builtin get takes the default argument
 (define-compiler-macro get* (sym prop &optional default)
 (list 'get sym prop default))
 (define-compiler-macro getf (sym prop &optional default)
 (list 'plist-get sym prop default))
 (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
 (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr)))
 ;;; Things that are inline.
 (proclaim '(inline floatp-safe acons map concatenate notany notevery
-;; XEmacs change
+;; XEmacs omission: gethash is builtin
-		   cl-set-elt revappend nreconc
+		   cl-set-elt revappend nreconc))
-		   ))
 ;;; Things that are side-effect-free.  Moved to byte-optimize.el
-;(dolist (fun '(oddp evenp plusp minusp
+;(mapcar (function (lambda (x) (put x 'side-effect-free t)))
-;		    abs expt signum last butlast ldiff
+;	'(oddp evenp signum last butlast ldiff pairlis gcd lcm
-;		    pairlis gcd lcm
+;	  isqrt floor* ceiling* truncate* round* mod* rem* subseq
-;		    isqrt floor* ceiling* truncate* round* mod* rem* subseq
+;	  list-length get* getf))
-;		    list-length getf))
-;  (put fun 'side-effect-free t))
 ;;; Things that are side-effect-and-error-free.  Moved to byte-optimize.el
-;(dolist (fun '(eql floatp-safe list* subst acons equalp random-state-p
+;(mapcar (function (lambda (x) (put x 'side-effect-free 'error-free)))
-;		   copy-tree sublis))
+;	'(eql floatp-safe list* subst acons equalp random-state-p
-;  (put fun 'side-effect-free 'error-free))
+;	  copy-tree sublis))
 (run-hooks 'cl-macs-load-hook)
+;;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
 ;;; cl-macs.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 2153:393039450288