Mercurial > hg > xemacs-beta
changeset 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 | d93fedcbf6be |
| children | 2332e27515ca |
| files | lisp/ChangeLog lisp/cl-compat.el lisp/cl-extra.el lisp/cl-macs.el lisp/cl-seq.el lisp/cl.el |
| diffstat | 6 files changed, 629 insertions(+), 653 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Fri Jun 25 21:50:24 2004 +0000 +++ b/lisp/ChangeLog Sat Jun 26 21:25:24 2004 +0000 @@ -1,3 +1,48 @@ +2004-06-24 Jerry James <james@xemacs.org> + + * cl-compat.el: Synch with Emacs 21.3. + * cl-extra.el: Ditto. + * cl-extra.el (cl-push): Removed because superfluous. + * cl-extra.el (cl-pop): Removed because superfluous. + * cl-extra.el (cl-emacs-type)): Removed because unused. + * cl-extra.el (cl-map-keymap): Just alias map-keymap. + * cl-extra.el (cl-map-keymap-recursively): Drop Emacs 18 support. + * cl-extra.el (cl-copy-tree): Removed because superfluous. + * cl-extra.el (cl-remprop): New alias. + * cl-extra.el (cl-make-hash-table): New alias. + * cl-extra.el (cl-hash-table-p): New alias. + * cl-extra.el (cl-hash-table-count): New alias. + * cl-macs.el: Synch with Emacs 21.3. + * cl-macs.el (cl-push): Removed because superfluous. + * cl-macs.el (cl-pop): Removed because superfluous. + * cl-macs.el (cl-emacs-type): Removed because unused. + * cl-macs.el (cl-compile-time-init): Drop Emacs 18 and 19 support. + * cl-macs.el (return): Change arg name to match Emacs and docstring. + * cl-macs.el (return-from): Ditto. + * cl-macs.el (loop): Check for 'collecting as well as 'collect. + * cl-macs.el (define-setf-expander): New alias. + * cl-macs.el (caar): New setf method. + * cl-macs.el (cadr): New setf method. + * cl-macs.el (cdar): New setf method. + * cl-macs.el (cddr): New setf method. + * cl-macs.el (deftype): Change arg name to match Emacs and docstring. + * cl-macs.el (ignore-errors): Change docstring to match arg name. + * cl-seq.el: Synch with Emacs 21.3. + * cl-seq.el (cl-push): Removed because superfluous. + * cl-seq.el (cl-pop): Removed because superfluous. + * cl-seq.el (mismatch): Typo fix. + * cl.el: Synch with Emacs 21.3. + * cl.el (cl-map-extents): Alias map-extents. + * cl.el (values): Change from defalias to defsubst to add docstring. + * cl.el (values-list): Ditto. + * cl.el (multiple-value-list): Ditto. + * cl.el (multiple-value-apply): Ditto. + * cl.el (nth-value): Ditto. + * cl.el (cl-abs): Alias the `abs' builtin instead. + * cl.el (svref): New alias. + * cl.el (cl-add-hook): Removed due to obsolescence. + * cl.el (cl-hack-byte-compiler): Set cl-hacked-flag first for safety. + 2004-06-26 Steve Youngs <steve@youngs.au.com> * package-get.el (package-get-info-name-array): New.
--- a/lisp/cl-compat.el Fri Jun 25 21:50:24 2004 +0000 +++ b/lisp/cl-compat.el Sat Jun 26 21:25:24 2004 +0000 @@ -23,7 +23,7 @@ ;; 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: @@ -56,11 +56,6 @@ (defmacro defkeyword (x &optional doc) (list* 'defconst x (list 'quote x) (and doc (list doc)))) -;; XEmacs change. -;; We have built-in function. -;;(defun keywordp (sym) -;; (and (symbolp sym) (eq (aref (symbol-name sym) 0) ?\:) (set sym sym))) - (defun keyword-of (sym) (or (keywordp sym) (keywordp (intern (format ":%s" sym))))) @@ -192,5 +187,5 @@ (provide 'cl-compat) +;;; arch-tag: 9996bb4f-aaf5-4592-b436-bf64759a3163 ;;; cl-compat.el ends here -
--- a/lisp/cl-extra.el Fri Jun 25 21:50:24 2004 +0000 +++ b/lisp/cl-extra.el Sat Jun 26 21:25:24 2004 +0000 @@ -1,6 +1,6 @@ ;;; cl-extra.el --- Common Lisp extensions for XEmacs Lisp (part two) -;; Copyright (C) 1993 Free Software Foundation, Inc. +;; Copyright (C) 1993,2000,2003 Free Software Foundation, Inc. ;; Copyright (C) 2002 Ben Wing. ;; Author: Dave Gillespie <daveg@synaptics.com> @@ -25,7 +25,7 @@ ;; 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: @@ -38,8 +38,6 @@ ;; This package was written by Dave Gillespie; it is a complete ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. ;; -;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19. -;; ;; Bug reports, comments, and suggestions are welcome! ;; This file contains portions of the Common Lisp extensions @@ -49,6 +47,7 @@ ;;; Code: +;; XEmacs addition (eval-when-compile (require 'obsolete)) @@ -56,16 +55,6 @@ (error "Tried to load `cl-extra' 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))))) - -(defvar cl-emacs-type) - - ;;; Type coercion. (defun coerce (x type) @@ -77,14 +66,18 @@ ((eq type 'array) (if (arrayp x) x (vconcat x))) ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) + ;; XEmacs addition character <-> integer coercions ((and (eq type 'character) (char-int-p x)) (int-char x)) ((and (eq type 'integer) (characterp x)) (char-int x)) ((eq type 'float) (float x)) + ;; XEmacs addition: enhanced numeric type coercions ((and (featurep 'number-types) (memq type '(integer ratio bigfloat)) (coerce-number x type))) + ;; XEmacs addition: bit-vector coercion ((eq type 'bit-vector) (if (bit-vector-p x) x (apply 'bit-vector (append x nil)))) + ;; XEmacs addition: weak-list coercion ((eq type 'weak-list) (if (weak-list-p x) x (let ((wl (make-weak-list))) @@ -103,8 +96,9 @@ strings case-insensitively." (cond ((eq x y) t) ((stringp x) - ;; avoids downcase + ;; XEmacs change: avoid downcase (eq t (compare-strings x nil nil y nil nil t))) + ;; XEmacs addition: compare characters ((characterp x) (and (characterp y) (or (char-equal x y) @@ -112,9 +106,8 @@ ((numberp x) (and (numberp y) (= x y))) ((consp x) - ;; XEmacs change (while (and (consp x) (consp y) (equalp (car x) (car y))) - (cl-pop x) (cl-pop y)) + (setq x (cdr x) y (cdr y))) (and (not (consp x)) (equalp x y))) ((vectorp x) (and (vectorp y) (= (length x) (length y)) @@ -144,7 +137,7 @@ (setcar cl-p1 (cdr (car cl-p1)))) (aref (car cl-p1) cl-i))) (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) - (cl-push (apply cl-func cl-args) cl-res) + (push (apply cl-func cl-args) cl-res) (setq cl-i (1+ cl-i))) (nreverse cl-res)) (let ((cl-res nil) @@ -153,9 +146,9 @@ (let ((cl-n (min (length cl-x) (length cl-y))) (cl-i -1)) (while (< (setq cl-i (1+ cl-i)) cl-n) - (cl-push (funcall cl-func - (if (consp cl-x) (cl-pop cl-x) (aref cl-x cl-i)) - (if (consp cl-y) (cl-pop cl-y) (aref cl-y cl-i))) + (push (funcall cl-func + (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) + (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) cl-res))) (nreverse cl-res)))) @@ -175,17 +168,17 @@ (cl-args (cons cl-list (copy-sequence cl-rest))) cl-p) (while (not (memq nil cl-args)) - (cl-push (apply cl-func cl-args) cl-res) + (push (apply cl-func cl-args) cl-res) (setq cl-p cl-args) - (while cl-p (setcar cl-p (cdr (cl-pop cl-p)) ))) + (while cl-p (setcar cl-p (cdr (pop cl-p)) ))) (nreverse cl-res)) (let ((cl-res nil)) (while cl-list - (cl-push (funcall cl-func cl-list) cl-res) + (push (funcall cl-func cl-list) cl-res) (setq cl-list (cdr cl-list))) (nreverse cl-res)))) - +;; XEmacs change: in Emacs, this function is named cl-mapc. (defun mapc (cl-func cl-seq &rest cl-rest) "Like `mapcar', but does not accumulate values returned by the function." (if cl-rest @@ -195,6 +188,9 @@ (mapc-internal cl-func cl-seq)) cl-seq) +;; XEmacs addition: FSF compatibility +(defalias 'cl-mapc 'mapc) + (defun mapl (cl-func cl-list &rest cl-rest) "Like `maplist', but does not accumulate values returned by the function." (if cl-rest @@ -222,7 +218,7 @@ (if cl-res (throw 'cl-some cl-res))))) cl-seq cl-rest) nil) (let ((cl-x nil)) - (while (and cl-seq (not (setq cl-x (funcall cl-pred (cl-pop cl-seq)))))) + (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq)))))) cl-x))) (defun every (cl-pred cl-seq &rest cl-rest) @@ -246,35 +242,19 @@ (not (apply 'every cl-pred cl-seq cl-rest))) ;;; Support for `loop'. -(defun cl-map-keymap (cl-func cl-map) - (while (symbolp cl-map) (setq cl-map (symbol-function cl-map))) - (if (eq cl-emacs-type 'lucid) (funcall 'map-keymap cl-func cl-map) - (if (listp cl-map) - (let ((cl-p cl-map)) - (while (consp (setq cl-p (cdr cl-p))) - (cond ((consp (car cl-p)) - (funcall cl-func (car (car cl-p)) (cdr (car cl-p)))) - ((vectorp (car cl-p)) - (cl-map-keymap cl-func (car cl-p))) - ((eq (car cl-p) 'keymap) - (setq cl-p nil))))) - (let ((cl-i -1)) - (while (< (setq cl-i (1+ cl-i)) (length cl-map)) - (if (aref cl-map cl-i) - (funcall cl-func cl-i (aref cl-map cl-i)))))))) +(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 (if (eq cl-emacs-type 18) "0" [0])))) - (cl-map-keymap + (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 - (funcall (if (eq cl-emacs-type 18) 'concat 'vconcat) - cl-base (list 0))) + (vconcat cl-base (list 0))) (funcall cl-func-rec cl-base cl-bind)))) cl-map)) @@ -282,17 +262,15 @@ (or cl-what (setq cl-what (current-buffer))) (if (bufferp cl-what) (let (cl-mark cl-mark2 (cl-next t) cl-next2) - (save-excursion - (set-buffer cl-what) + (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 (and-fboundp 'next-property-change - (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 (save-excursion - (set-buffer cl-what) (point-max)))) + (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))) @@ -300,10 +278,9 @@ (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 (and-fboundp 'next-property-change - (if cl-prop (next-single-property-change - cl-start cl-prop cl-what) - (next-property-change cl-start cl-what))) + (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))))) @@ -316,8 +293,7 @@ ;; This is the preferred algorithm, though overlay-lists is ;; undocumented. (let (cl-ovl) - (save-excursion - (set-buffer cl-buffer) + (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)))) @@ -333,10 +309,10 @@ (if cl-end (set-marker cl-end nil))) ;; This alternate algorithm fails to find zero-length overlays. - (let ((cl-mark (save-excursion (set-buffer cl-buffer) - (copy-marker (or cl-start (point-min))))) - (cl-mark2 (and cl-end (save-excursion (set-buffer cl-buffer) - (copy-marker cl-end)))) + (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)) @@ -363,28 +339,28 @@ (defvar cl-progv-save) (defun cl-progv-before (syms values) (while syms - (cl-push (if (boundp (car syms)) + (push (if (boundp (car syms)) (cons (car syms) (symbol-value (car syms))) (car syms)) cl-progv-save) (if values - (set (cl-pop syms) (cl-pop values)) - (makunbound (cl-pop syms))))) + (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))) - (cl-pop cl-progv-save))) + (pop cl-progv-save))) ;;; Numbers. (defun gcd (&rest args) "Return the greatest common divisor of the arguments." - (let ((a (abs (or (cl-pop args) 0)))) + (let ((a (abs (or (pop args) 0)))) (while args - (let ((b (abs (cl-pop args)))) + (let ((b (abs (pop args)))) (while (> b 0) (setq b (% a (setq a b)))))) a)) @@ -392,9 +368,9 @@ "Return the least common multiple of the arguments." (if (memq 0 args) 0 - (let ((a (abs (or (cl-pop args) 1)))) + (let ((a (abs (or (pop args) 1)))) (while args - (let ((b (abs (cl-pop args)))) + (let ((b (abs (pop args)))) (setq a (* (/ a (gcd a b)) b)))) a))) @@ -410,6 +386,7 @@ g) (if (eq a 0) 0 (signal 'arith-error nil)))) +;; XEmacs addition (defun cl-expt (x y) "Return X raised to the power of Y. Works only for integer arguments." (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0)) @@ -576,7 +553,7 @@ ; (if end ; (let ((res nil)) ; (while (>= (setq end (1- end)) start) -; (cl-push (cl-pop seq) res)) +; (push (pop seq) res)) ; (nreverse res)) ; (copy-sequence seq))) ; (t @@ -590,6 +567,7 @@ (defun concatenate (type &rest seqs) "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." + ;; XEmacs change: use case instead of cond for clarity (case type (vector (apply 'vconcat seqs)) (string (apply 'concat seqs)) @@ -619,25 +597,7 @@ (setq list (cdr list))) (if (numberp sublist) (equal sublist list) (eq sublist list))) -(defun cl-copy-tree (tree &optional vecp) - "Make a copy of TREE. -If TREE is a cons cell, this recursively copies both its car and its cdr. -Contrast to copy-sequence, which copies only along the cdrs. With second -argument VECP, this copies vectors as well as conses." - (if (consp tree) - (let ((p (setq tree (copy-list tree)))) - (while (consp p) - (if (or (consp (car p)) (and vecp (vectorp (car p)))) - (setcar p (cl-copy-tree (car p) vecp))) - (or (listp (cdr p)) (setcdr p (cl-copy-tree (cdr p) vecp))) - (cl-pop p))) - (if (and vecp (vectorp tree)) - (let ((i (length (setq tree (copy-sequence tree))))) - (while (>= (setq i (1- i)) 0) - (aset tree i (cl-copy-tree (aref tree i) vecp)))))) - tree) -(or (and (fboundp 'copy-tree) (subrp (symbol-function 'copy-tree))) - (defalias 'copy-tree 'cl-copy-tree)) +(defalias 'cl-copy-tree 'copy-tree) ;;; Property lists. @@ -656,6 +616,11 @@ (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) +;; XEmacs change: we have a builtin remprop +(defalias 'cl-remprop 'remprop) + + + ;;; Hash tables. ;; The `regular' Common Lisp hash-table stuff has been moved into C. @@ -696,6 +661,10 @@ (defalias 'cl-remhash 'remhash) (defalias 'cl-clrhash 'clrhash) (defalias 'cl-maphash 'maphash) +;; These three actually didn't exist in Emacs-20. +(defalias 'cl-make-hash-table 'make-hash-table) +(defalias 'cl-hash-table-p 'hash-table-p) +(defalias 'cl-hash-table-count 'hash-table-count) ;;; Some debugging aids. @@ -717,6 +686,7 @@ (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 (") @@ -756,7 +726,7 @@ (cl-macroexpand-all (cons 'progn (cddr form)) env) (let ((letf nil) (res nil) (lets (cadr form))) (while lets - (cl-push (if (consp (car lets)) + (push (if (consp (car lets)) (let ((exp (cl-macroexpand-all (caar lets) env))) (or (symbolp exp) (setq letf t)) (cons exp (cl-macroexpand-body (cdar lets) env))) @@ -785,13 +755,14 @@ (sub (pairlis cl-closure-vars new)) (decls nil)) (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) - (cl-push (list 'quote (cl-pop body)) decls)) + (push (list 'quote (pop body)) decls)) (put (car (last cl-closure-vars)) 'used t) (append (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) (sublis sub (nreverse decls)) (list (list* 'list '(quote apply) + ;; XEmacs: put a quote before the function (list 'list '(quote quote) (list 'function (list* 'lambda @@ -804,6 +775,7 @@ '((quote --cl-rest--))))))) (list (car form) (list* 'lambda (cadadr form) body)))) (let ((found (assq (cadr form) env))) + ;; XEmacs: cadr/caddr operate on nil without errors (if (eq (cadr (caddr found)) 'cl-labels-args) (cl-macroexpand-all (cadr (caddr (cadddr found))) env) form)))) @@ -834,6 +806,8 @@ (run-hooks 'cl-extra-load-hook) +;; XEmacs addition (provide 'cl-extra) +;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed ;;; cl-extra.el ends here
--- a/lisp/cl-macs.el Fri Jun 25 21:50:24 2004 +0000 +++ b/lisp/cl-macs.el Sat Jun 26 21:25:24 2004 +0000 @@ -1,6 +1,6 @@ ;;; 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> @@ -24,7 +24,7 @@ ;; 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: @@ -35,8 +35,6 @@ ;; 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 @@ -53,20 +51,11 @@ (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) @@ -76,7 +65,6 @@ (require (progn - (or (fboundp 'defalias) (fset 'defalias 'fset)) (or (fboundp 'cl-transform-function-property) (defalias 'cl-transform-function-property #'(lambda (n p f) @@ -89,24 +77,101 @@ (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 @@ -223,7 +288,7 @@ (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))))) @@ -261,15 +326,15 @@ ;; Add CL lambda list to documentation. npak@ispras.ru (if (and (stringp (car body)) (cdr body)) - (setq doc (cl-pop body))) - (cl-push (concat doc - "\nCommon Lisp lambda list:\n" - " " (cl-function-arglist bind-block args) - "\n\n") - header) + (setq doc (pop body))) + (push (concat doc + "\nCommon Lisp lambda list:\n" + " " (cl-function-arglist bind-block args) + "\n\n") + 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))) @@ -285,19 +350,21 @@ (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))))))) @@ -306,7 +373,7 @@ (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))) @@ -320,9 +387,9 @@ (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))) @@ -336,7 +403,7 @@ (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) @@ -344,9 +411,9 @@ (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) @@ -361,16 +428,16 @@ (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))))) @@ -399,13 +466,14 @@ '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)) - bind-inits))))))) + (push (list 'setq karg (list 'quote karg)) + 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)) @@ -427,24 +495,24 @@ (format "Keyword argument %%s not one of %s" keys) (list 'car var))))))) - (cl-push (list 'let (list (list var restarg)) check) bind-forms))) - (while (and (eq (car args) '&aux) (cl-pop args)) + (push (list 'let (list (list var restarg)) check) bind-forms))) + (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)))) - (cl-do-arglist (caar args) (cadr (cl-pop args)))) - (cl-do-arglist (cl-pop args) nil)))) + (list 'quote (cadr (pop args)))) + (cl-do-arglist (caar args) (cadr (pop args)))) + (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)))))) @@ -492,13 +560,13 @@ 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) @@ -509,18 +577,11 @@ (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. @@ -564,6 +625,7 @@ (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" @@ -579,7 +641,7 @@ (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)))) @@ -595,6 +657,7 @@ (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 @@ -619,7 +682,7 @@ (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)))) @@ -672,20 +735,20 @@ (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. @@ -993,10 +1056,10 @@ (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) - (cl-push (list 'setq loop-first-flag nil) loop-steps))) + (progn (push (list (list loop-first-flag t)) loop-bindings) + (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))) @@ -1027,21 +1090,21 @@ (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))) @@ -1051,39 +1114,39 @@ (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)))) - (setq word (cl-pop args)) - (if (eq word 'being) (setq word (cl-pop args))) - (if (memq word '(the each)) (setq word (cl-pop args))) + (let ((var (or (pop args) (gensym)))) + (setq word (pop args)) + (if (eq word 'being) (setq word (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) @@ -1101,31 +1164,31 @@ (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) - (if end-var (cl-push (list end-var end) loop-for-bindings)) - (if step-var (cl-push (list step-var step) + (push (list var (or start 0)) loop-for-bindings) + (if end-var (push (list end-var end) loop-for-bindings)) + (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) - (cl-push (list 'consp temp) loop-body) + (push (list temp (pop args)) loop-for-bindings) + (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) - (cl-push (list var (if on temp (list 'car temp))) + (push (list var nil) loop-for-bindings) + (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) @@ -1138,20 +1201,20 @@ 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)) - (cl-push (list var + (push (list var then) loop-for-steps)) + (push (list var (if (eq start then) start (list 'if (or loop-first-flag @@ -1161,15 +1224,15 @@ ((memq word '(across across-ref)) (let ((temp-vec (gensym)) (temp-idx (gensym))) - (cl-push (list temp-vec (cl-pop args)) loop-for-bindings) - (cl-push (list temp-idx -1) loop-for-bindings) - (cl-push (list '< (list 'setq temp-idx (list '1+ temp-idx)) + (push (list temp-vec (pop args)) loop-for-bindings) + (push (list temp-idx -1) loop-for-bindings) + (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) - (cl-push (list var (list 'aref temp-vec temp-idx)) + (push (list var nil) loop-for-bindings) + (push (list var (list 'aref temp-vec temp-idx)) loop-for-sets)))) ((memq word '(element elements)) @@ -1184,26 +1247,26 @@ (cadr (cl-pop2 args)) (error "Bad `using' clause")) (gensym)))) - (cl-push (list temp-seq seq) loop-for-bindings) - (cl-push (list temp-idx 0) loop-for-bindings) + (push (list temp-seq seq) 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)) - (cl-push (list var nil) loop-for-bindings) - (cl-push (list 'and temp-seq + (push (list '< temp-idx temp-len) loop-body)) + (push (list var nil) loop-for-bindings) + (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) @@ -1254,7 +1317,7 @@ (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) @@ -1273,38 +1336,39 @@ (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) - (cl-push (list 'prog1 (list 'not (list 'eq var temp)) + (push (list temp nil) loop-for-bindings) + (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) - (cl-push (list 'prog1 (list 'not (list 'eq var temp)) + (push (list temp nil) loop-for-bindings) + (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) @@ -1314,38 +1378,38 @@ (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) - (cl-push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) - - ((eq word 'collect) - (let ((what (cl-pop args)) + (push (list (list temp (pop args))) loop-bindings) + (push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body))) + + ((memq word '(collect collecting)) + (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) - (cl-push (list 'progn + (push (list 'progn (list 'push what var) t) loop-body) + (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 @@ -1358,105 +1422,106 @@ 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)) - (cl-push (nreverse bindings) loop-bindings))) + (pop args)) + (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 - (list 'not (list 'setq loop-result-var (cl-pop args)))) + (push (list 'setq loop-finish-flag + (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)) - (cl-push (cons 'progn (nreverse (cons t body))) loop-body))) + (while (consp (car args)) (push (pop args) 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 @@ -1464,7 +1529,7 @@ (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)) @@ -1476,24 +1541,24 @@ (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)) @@ -1504,12 +1569,12 @@ (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) - (cl-push var loop-accum-vars))) + (progn (push (list (list var def)) loop-bindings) + (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)) @@ -1528,8 +1593,8 @@ (cdadr clauses) (list (cadr clauses)))) (cddr clauses))) - (setq body (cdr (butlast (cl-pop clauses))))) - (cl-push (cl-pop clauses) ands))) + (setq body (cdr (butlast (pop clauses))))) + (push (pop clauses) ands))) (setq ands (or (nreverse ands) (list t))) (list (if (cdr ands) (cons 'and ands) (car ands)) body @@ -1663,7 +1728,7 @@ (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) @@ -1677,10 +1742,10 @@ (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) (while bindings (let ((var (gensym))) - (cl-push var vars) - (cl-push (list 'function* (cons 'lambda (cdar bindings))) sets) - (cl-push var sets) - (cl-push (list (car (cl-pop bindings)) 'lambda '(&rest cl-labels-args) + (push var vars) + (push (list 'function* (cons 'lambda (cdar bindings))) sets) + (push var sets) + (push (list (car (pop bindings)) 'lambda '(&rest cl-labels-args) (list 'list* '(quote funcall) (list 'quote var) 'cl-labels-args)) cl-macro-environment))) @@ -1727,8 +1792,9 @@ (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 @@ -1766,7 +1832,7 @@ (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) @@ -1805,7 +1871,7 @@ (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 @@ -1828,11 +1894,12 @@ (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)))) @@ -1879,15 +1946,15 @@ ;;; 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)) - (cl-do-proclaim (cl-pop specs) nil))) + (if (listp cl-declare-stack) (push (car specs) cl-declare-stack)) + (cl-do-proclaim (pop specs) nil))) nil) @@ -1906,9 +1973,10 @@ (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) @@ -1991,19 +2059,24 @@ 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) @@ -2023,6 +2096,7 @@ ;;; 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) @@ -2039,16 +2113,18 @@ (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)) @@ -2057,16 +2133,18 @@ (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) - `(progn (set-frame-width ,f ,v) ,v)) -(defsetf frame-height (&optional f) (v) - `(progn (set-frame-height ,f ,v) ,v)) +;; XEmacs addition (defsetf current-frame-configuration set-frame-configuration) ;; XEmacs: new stuff @@ -2138,12 +2216,13 @@ (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) @@ -2169,9 +2248,13 @@ (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) @@ -2255,6 +2338,7 @@ (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)) @@ -2317,8 +2401,8 @@ (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) - (cl-push (list (cl-pop temps) (cl-pop values)) lets))) + (push (cons (pop temps) (pop values)) subs) + (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))))) @@ -2348,7 +2432,7 @@ 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)) @@ -2367,9 +2451,9 @@ (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)) @@ -2417,17 +2501,18 @@ "(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) - (setq place (cl-pop args))) + (push (list 'setq place (car args)) sets) + (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)))))) @@ -2443,13 +2528,13 @@ (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)))))) @@ -2526,7 +2611,7 @@ (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 @@ -2599,38 +2684,38 @@ (forms nil) pred-form pred-check) (if (stringp (car descs)) - (cl-push (list 'put (list 'quote name) '(quote structure-documentation) - (cl-pop descs)) forms)) + (push (list 'put (list 'quote name) '(quote structure-documentation) + (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)))) - (cond ((eq opt ':conc-name) + (args (cdr-safe (pop opts)))) + (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 @@ -2656,14 +2741,14 @@ (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))))) @@ -2674,7 +2759,7 @@ (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) @@ -2695,19 +2780,19 @@ (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) - (cl-push (and (eq slot 'cl-tag-slot) (list 'quote tag)) + (push nil slots) + (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) - (cl-push (nth 1 desc) defaults) - (cl-push (list* + (push slot slots) + (push (nth 1 desc) defaults) + (push (list* 'defsubst* accessor '(cl-x) (append (and pred-check @@ -2719,9 +2804,9 @@ (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) - (cl-push (list 'define-setf-method accessor '(cl-x) - (if (cadr (memq ':read-only (cddr desc))) + (push (cons accessor t) side-eff) + (push (list 'define-setf-method accessor '(cl-x) + (if (cadr (memq :read-only (cddr desc))) (list 'error (format "%s is a read-only slot" accessor)) (list 'cl-struct-setf-expander 'cl-x @@ -2737,38 +2822,38 @@ (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) - (cl-push (cons copier t) side-eff))) + (progn (push (list 'defun copier '(x) '(copy-sequence x)) forms) + (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) - (cl-push (list* 'eval-when '(compile load eval) + (push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms) + (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) @@ -2812,23 +2897,24 @@ ;;; 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) (list 'null val)) - ((eq type 'float) (list 'floatp-safe val)) - ((eq type 'real) (list 'numberp val)) - ((eq type 'fixnum) (list 'integerp val)) + ((eq type 'null) `(null ,val)) + ((eq type 'float) `(floatp-safe ,val)) + ((eq type 'real) `(numberp ,val)) + ((eq type 'fixnum) `(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")))) @@ -2864,23 +2950,21 @@ (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)) - (< cl-optimize-speed 3) - (= cl-optimize-safety 3)) - (let* ((temp (if (cl-simple-expr-p place 3) place (gensym))) - (test (cl-make-type-test temp type)) - (signal-error `(signal 'wrong-type-argument - ,(list 'list (or string (list 'quote type)) - temp (list 'quote place)))) - (body - (condition-case nil - `(while (not ,test) - ,(macroexpand `(setf ,place ,signal-error))) - (error - `(if ,test (progn ,signal-error nil)))))) - (if (eq temp place) - body - `(let ((,temp ,place)) ,body))))) + (and (or (not (cl-compiling-file)) + (< cl-optimize-speed 3) (= cl-optimize-safety 3)) + (let* ((temp (if (cl-simple-expr-p place 3) place (gensym))) + (test (cl-make-type-test temp type)) + (signal-error `(signal 'wrong-type-argument + ,(list 'list (or string (list 'quote type)) + temp (list 'quote place)))) + (body + (condition-case nil + `(while (not ,test) + ,(macroexpand `(setf ,place ,signal-error))) + (error + `(if ,test (progn ,signal-error nil)))))) + (if (eq temp place) `(progn ,body nil) + `(let ((,temp ,place)) ,body nil))))) ;;;###autoload (defmacro assert (form &optional show-args string &rest args) @@ -2906,99 +2990,17 @@ ;;;###autoload (defmacro ignore-errors (&rest body) - "Execute FORMS; if an error occurs, return nil. -Otherwise, return result of last FORM." + "Execute BODY; if an error occurs, return nil. +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. @@ -3015,8 +3017,8 @@ 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)) - (setq args (nreverse res)) (setcdr res (and p (list '&rest p)))) + (while (consp p) (push (pop p) res)) + (setq args (nconc (nreverse res) (and p (list '&rest p))))) (list 'eval-when '(compile load eval) (cl-transform-function-property func 'cl-compiler-macro @@ -3053,11 +3055,13 @@ (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))) @@ -3105,7 +3109,7 @@ (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)) @@ -3127,7 +3131,7 @@ (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)) @@ -3138,7 +3142,7 @@ (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)) @@ -3149,6 +3153,7 @@ (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)) @@ -3193,24 +3198,22 @@ ;;; Things that are inline. (proclaim '(inline floatp-safe acons map concatenate notany notevery -;; XEmacs change - cl-set-elt revappend nreconc - )) +;; XEmacs omission: gethash is builtin + cl-set-elt revappend nreconc)) ;;; Things that are side-effect-free. Moved to byte-optimize.el -;(dolist (fun '(oddp evenp plusp minusp -; abs expt signum last butlast ldiff -; pairlis gcd lcm -; isqrt floor* ceiling* truncate* round* mod* rem* subseq -; list-length getf)) -; (put fun 'side-effect-free t)) +;(mapcar (function (lambda (x) (put x 'side-effect-free t))) +; '(oddp evenp signum last butlast ldiff pairlis gcd lcm +; isqrt floor* ceiling* truncate* round* mod* rem* subseq +; list-length get* getf)) ;;; 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 -; copy-tree sublis)) -; (put fun 'side-effect-free 'error-free)) +;(mapcar (function (lambda (x) (put x 'side-effect-free 'error-free))) +; '(eql floatp-safe list* subst acons equalp random-state-p +; copy-tree sublis)) (run-hooks 'cl-macs-load-hook) +;;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46 ;;; cl-macs.el ends here
--- a/lisp/cl-seq.el Fri Jun 25 21:50:24 2004 +0000 +++ b/lisp/cl-seq.el Sat Jun 26 21:25:24 2004 +0000 @@ -24,7 +24,7 @@ ;; 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: @@ -53,14 +53,6 @@ (error "Tried to load `cl-seq' 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))))) - - ;;; Keyword parsing. This is special-cased here so that we can compile ;;; this file independent from cl-macs. @@ -90,9 +82,9 @@ (let* ((var (if (consp x) (car x) x)) (mem (list 'car (list 'cdr (list 'memq (list 'quote var) 'cl-keys))))) - (if (eq var ':test-not) + (if (eq var :test-not) (setq mem (list 'and mem (list 'setq 'cl-test mem) t))) - (if (eq var ':if-not) + (if (eq var :if-not) (setq mem (list 'and mem (list 'setq 'cl-if mem) t))) (list (intern (format "cl-%s" (substring (symbol-name var) 1))) @@ -161,16 +153,16 @@ (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) (setq cl-seq (subseq cl-seq cl-start cl-end)) (if cl-from-end (setq cl-seq (nreverse cl-seq))) - (let ((cl-accum (cond ((memq ':initial-value cl-keys) cl-initial-value) - (cl-seq (cl-check-key (cl-pop cl-seq))) + (let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value) + (cl-seq (cl-check-key (pop cl-seq))) (t (funcall cl-func))))) (if cl-from-end (while cl-seq - (setq cl-accum (funcall cl-func (cl-check-key (cl-pop cl-seq)) + (setq cl-accum (funcall cl-func (cl-check-key (pop cl-seq)) cl-accum))) (while cl-seq (setq cl-accum (funcall cl-func cl-accum - (cl-check-key (cl-pop cl-seq)))))) + (cl-check-key (pop cl-seq)))))) cl-accum))) (defun fill (seq item &rest cl-keys) @@ -247,8 +239,8 @@ (if cl-i (let ((cl-res (apply 'delete* cl-item (append cl-seq nil) (append (if cl-from-end - (list ':end (1+ cl-i)) - (list ':start cl-i)) + (list :end (1+ cl-i)) + (list :start cl-i)) cl-keys)))) (if (listp cl-seq) cl-res (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))) @@ -271,8 +263,8 @@ (and (cdr cl-p) (apply 'delete* cl-item (copy-sequence (cdr cl-p)) - ':start 0 ':end (1- cl-end) - ':count (1- cl-count) cl-keys)))) + :start 0 :end (1- cl-end) + :count (1- cl-count) cl-keys)))) cl-seq)) cl-seq))))) @@ -281,14 +273,14 @@ This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. Keywords supported: :key :count :start :end :from-end" - (apply 'remove* nil cl-list ':if cl-pred cl-keys)) + (apply 'remove* nil cl-list :if cl-pred cl-keys)) (defun remove-if-not (cl-pred cl-list &rest cl-keys) "Remove all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. Keywords supported: :key :count :start :end :from-end" - (apply 'remove* nil cl-list ':if-not cl-pred cl-keys)) + (apply 'remove* nil cl-list :if-not cl-pred cl-keys)) (defun delete* (cl-item cl-seq &rest cl-keys) "Remove all occurrences of ITEM in SEQ. @@ -336,17 +328,15 @@ "Remove all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. Keywords supported: :key :count :start :end :from-end" - (apply 'delete* nil cl-list ':if cl-pred cl-keys)) + (apply 'delete* nil cl-list :if cl-pred cl-keys)) (defun delete-if-not (cl-pred cl-list &rest cl-keys) "Remove all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. Keywords supported: :key :count :start :end :from-end" - (apply 'delete* nil cl-list ':if-not cl-pred cl-keys)) + (apply 'delete* nil cl-list :if-not cl-pred cl-keys)) -(or (and (fboundp 'delete) (subrp (symbol-function 'delete))) - (defalias 'delete (function (lambda (x y) (delete* x y ':test 'equal))))) - +;; XEmacs change: this is in subr.el in Emacs (defun remove (cl-item cl-seq) "Remove all occurrences of ITEM in SEQ, testing with `equal' This is a non-destructive function; it makes a copy of SEQ if necessary @@ -354,6 +344,7 @@ Also see: `remove*', `delete', `delete*'" (remove* cl-item cl-seq ':test 'equal)) +;; XEmacs change: this is in subr.el in Emacs (defun remq (cl-elt cl-list) "Remove all occurrences of ELT in LIST, comparing with `eq'. This is a non-destructive function; it makes a copy of LIST to avoid @@ -430,22 +421,22 @@ (or cl-from-end (progn (cl-set-elt cl-seq cl-i cl-new) (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) - (apply 'nsubstitute cl-new cl-old cl-seq ':count cl-count - ':start cl-i cl-keys)))))) + (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count + :start cl-i cl-keys)))))) (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) "Substitute NEW for all items satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. Keywords supported: :key :count :start :end :from-end" - (apply 'substitute cl-new nil cl-list ':if cl-pred cl-keys)) + (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys)) (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) "Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a non-destructive function; it makes a copy of SEQ if necessary to avoid corrupting the original SEQ. Keywords supported: :key :count :start :end :from-end" - (apply 'substitute cl-new nil cl-list ':if-not cl-pred cl-keys)) + (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys)) (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) "Substitute NEW for OLD in SEQ. @@ -483,13 +474,13 @@ "Substitute NEW for all items satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. Keywords supported: :key :count :start :end :from-end" - (apply 'nsubstitute cl-new nil cl-list ':if cl-pred cl-keys)) + (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys)) (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) "Substitute NEW for all items not satisfying PREDICATE in SEQ. This is a destructive function; it reuses the storage of SEQ whenever possible. Keywords supported: :key :count :start :end :from-end" - (apply 'nsubstitute cl-new nil cl-list ':if-not cl-pred cl-keys)) + (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys)) (defun find (cl-item cl-seq &rest cl-keys) "Find the first occurrence of ITEM in LIST. @@ -502,13 +493,13 @@ "Find the first item satisfying PREDICATE in LIST. Return the matching ITEM, or nil if not found. Keywords supported: :key :start :end :from-end" - (apply 'find nil cl-list ':if cl-pred cl-keys)) + (apply 'find nil cl-list :if cl-pred cl-keys)) (defun find-if-not (cl-pred cl-list &rest cl-keys) "Find the first item not satisfying PREDICATE in LIST. Return the matching ITEM, or nil if not found. Keywords supported: :key :start :end :from-end" - (apply 'find nil cl-list ':if-not cl-pred cl-keys)) + (apply 'find nil cl-list :if-not cl-pred cl-keys)) (defun position (cl-item cl-seq &rest cl-keys) "Find the first occurrence of ITEM in LIST. @@ -543,13 +534,13 @@ "Find the first item satisfying PREDICATE in LIST. Return the index of the matching item, or nil if not found. Keywords supported: :key :start :end :from-end" - (apply 'position nil cl-list ':if cl-pred cl-keys)) + (apply 'position nil cl-list :if cl-pred cl-keys)) (defun position-if-not (cl-pred cl-list &rest cl-keys) "Find the first item not satisfying PREDICATE in LIST. Return the index of the matching item, or nil if not found. Keywords supported: :key :start :end :from-end" - (apply 'position nil cl-list ':if-not cl-pred cl-keys)) + (apply 'position nil cl-list :if-not cl-pred cl-keys)) (defun count (cl-item cl-seq &rest cl-keys) "Count the number of occurrences of ITEM in LIST. @@ -559,7 +550,7 @@ (or cl-end (setq cl-end (length cl-seq))) (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) (while (< cl-start cl-end) - (setq cl-x (if (consp cl-seq) (cl-pop cl-seq) (aref cl-seq cl-start))) + (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start))) (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) (setq cl-start (1+ cl-start))) cl-count))) @@ -567,17 +558,17 @@ (defun count-if (cl-pred cl-list &rest cl-keys) "Count the number of items satisfying PREDICATE in LIST. Keywords supported: :key :start :end" - (apply 'count nil cl-list ':if cl-pred cl-keys)) + (apply 'count nil cl-list :if cl-pred cl-keys)) (defun count-if-not (cl-pred cl-list &rest cl-keys) "Count the number of items not satisfying PREDICATE in LIST. Keywords supported: :key :start :end" - (apply 'count nil cl-list ':if-not cl-pred cl-keys)) + (apply 'count nil cl-list :if-not cl-pred cl-keys)) (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys) "Compare SEQ1 with SEQ2, return index of first mismatching element. Return nil if the sequences match. If one sequence is a prefix of the -other, the return value indicates the end of the shorted sequence. +other, the return value indicates the end of the shorter sequence. Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end" (cl-parsing-keywords (:test :test-not :key :from-end (:start1 0) :end1 (:start2 0) :end2) () @@ -622,9 +613,9 @@ (setq cl-pos (cl-position cl-first cl-seq2 cl-start2 cl-end2 cl-from-end)) (apply 'mismatch cl-seq1 cl-seq2 - ':start1 (1+ cl-start1) ':end1 cl-end1 - ':start2 (1+ cl-pos) ':end2 (+ cl-pos cl-len) - ':from-end nil cl-keys)) + :start1 (1+ cl-start1) :end1 cl-end1 + :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len) + :from-end nil cl-keys)) (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos)))) (and (< cl-start2 cl-end2) cl-pos))))) @@ -659,8 +650,8 @@ (while (and cl-seq1 cl-seq2) (if (funcall cl-pred (cl-check-key (car cl-seq2)) (cl-check-key (car cl-seq1))) - (cl-push (cl-pop cl-seq2) cl-res) - (cl-push (cl-pop cl-seq1) cl-res))) + (push (pop cl-seq2) cl-res) + (push (pop cl-seq1) cl-res))) (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) ;;; See compiler macro in cl-macs.el @@ -681,13 +672,13 @@ "Find the first item satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. Keywords supported: :key" - (apply 'member* nil cl-list ':if cl-pred cl-keys)) + (apply 'member* nil cl-list :if cl-pred cl-keys)) (defun member-if-not (cl-pred cl-list &rest cl-keys) "Find the first item not satisfying PREDICATE in LIST. Return the sublist of LIST whose car matches. Keywords supported: :key" - (apply 'member* nil cl-list ':if-not cl-pred cl-keys)) + (apply 'member* nil cl-list :if-not cl-pred cl-keys)) (defun cl-adjoin (cl-item cl-list &rest cl-keys) (if (cl-parsing-keywords (:key) t @@ -713,12 +704,12 @@ (defun assoc-if (cl-pred cl-list &rest cl-keys) "Find the first item whose car satisfies PREDICATE in LIST. Keywords supported: :key" - (apply 'assoc* nil cl-list ':if cl-pred cl-keys)) + (apply 'assoc* nil cl-list :if cl-pred cl-keys)) (defun assoc-if-not (cl-pred cl-list &rest cl-keys) "Find the first item whose car does not satisfy PREDICATE in LIST. Keywords supported: :key" - (apply 'assoc* nil cl-list ':if-not cl-pred cl-keys)) + (apply 'assoc* nil cl-list :if-not cl-pred cl-keys)) (defun rassoc* (cl-item cl-alist &rest cl-keys) "Find the first item whose cdr matches ITEM in LIST. @@ -735,12 +726,12 @@ (defun rassoc-if (cl-pred cl-list &rest cl-keys) "Find the first item whose cdr satisfies PREDICATE in LIST. Keywords supported: :key" - (apply 'rassoc* nil cl-list ':if cl-pred cl-keys)) + (apply 'rassoc* nil cl-list :if cl-pred cl-keys)) (defun rassoc-if-not (cl-pred cl-list &rest cl-keys) "Find the first item whose cdr does not satisfy PREDICATE in LIST. Keywords supported: :key" - (apply 'rassoc* nil cl-list ':if-not cl-pred cl-keys)) + (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys)) (defun union (cl-list1 cl-list2 &rest cl-keys) "Combine LIST1 and LIST2 using a set-union operation. @@ -757,8 +748,8 @@ (if (or cl-keys (numberp (car cl-list2))) (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys)) (or (memq (car cl-list2) cl-list1) - (cl-push (car cl-list2) cl-list1))) - (cl-pop cl-list2)) + (push (car cl-list2) cl-list1))) + (pop cl-list2)) cl-list1))) (defun nunion (cl-list1 cl-list2 &rest cl-keys) @@ -787,8 +778,8 @@ (apply 'member* (cl-check-key (car cl-list2)) cl-list1 cl-keys) (memq (car cl-list2) cl-list1)) - (cl-push (car cl-list2) cl-res)) - (cl-pop cl-list2)) + (push (car cl-list2) cl-res)) + (pop cl-list2)) cl-res))))) (defun nintersection (cl-list1 cl-list2 &rest cl-keys) @@ -813,8 +804,8 @@ (apply 'member* (cl-check-key (car cl-list1)) cl-list2 cl-keys) (memq (car cl-list1) cl-list2)) - (cl-push (car cl-list1) cl-res)) - (cl-pop cl-list1)) + (push (car cl-list1) cl-res)) + (pop cl-list1)) cl-res)))) (defun nset-difference (cl-list1 cl-list2 &rest cl-keys) @@ -858,20 +849,20 @@ (while (and cl-list1 (apply 'member* (cl-check-key (car cl-list1)) cl-list2 cl-keys)) - (cl-pop cl-list1)) + (pop cl-list1)) (null cl-list1))))) (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys) "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all matching elements replaced by NEW. Keywords supported: :key" - (apply 'sublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys)) + (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). Return a copy of TREE with all non-matching elements replaced by NEW. Keywords supported: :key" - (apply 'sublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys)) + (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) (defun nsubst (cl-new cl-old cl-tree &rest cl-keys) "Substitute NEW for OLD everywhere in TREE (destructively). @@ -884,13 +875,13 @@ "Substitute NEW for elements matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). Keywords supported: :key" - (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if cl-pred cl-keys)) + (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) "Substitute NEW for elements not matching PREDICATE in TREE (destructively). Any element of TREE which matches is changed to NEW (via a call to `setcar'). Keywords supported: :key" - (apply 'nsublis (list (cons nil cl-new)) cl-tree ':if-not cl-pred cl-keys)) + (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) (defun sublis (cl-alist cl-tree &rest cl-keys) "Perform substitutions indicated by ALIST in TREE (non-destructively). @@ -952,4 +943,5 @@ (run-hooks 'cl-seq-load-hook) +;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c ;;; cl-seq.el ends here
--- a/lisp/cl.el Fri Jun 25 21:50:24 2004 +0000 +++ b/lisp/cl.el Sat Jun 26 21:25:24 2004 +0000 @@ -24,7 +24,7 @@ ;; 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: @@ -37,8 +37,6 @@ ;; This package was written by Dave Gillespie; it is a complete ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. ;; -;; This package works with Emacs 18, Emacs 19, and XEmacs/Lucid Emacs 19. -;; ;; Bug reports, comments, and suggestions are welcome! ;; This file contains the portions of the Common Lisp extensions @@ -107,34 +105,10 @@ 'lucid) (t 19))) -(or (fboundp 'defalias) (fset 'defalias 'fset)) - (defvar cl-optimize-speed 1) (defvar cl-optimize-safety 1) -;;; Keywords used in this package. - -;;; XEmacs - keywords are done in Fintern(). -;;; -;;; (defconst :test ':test) -;;; (defconst :test-not ':test-not) -;;; (defconst :key ':key) -;;; (defconst :start ':start) -;;; (defconst :start1 ':start1) -;;; (defconst :start2 ':start2) -;;; (defconst :end ':end) -;;; (defconst :end1 ':end1) -;;; (defconst :end2 ':end2) -;;; (defconst :count ':count) -;;; (defconst :initial-value ':initial-value) -;;; (defconst :size ':size) -;;; (defconst :from-end ':from-end) -;;; (defconst :rehash-size ':rehash-size) -;;; (defconst :rehash-threshold ':rehash-threshold) -;;; (defconst :allow-other-keys ':allow-other-keys) - - (defvar custom-print-functions nil "This is a list of functions that format user objects for printing. Each function is called in turn with three arguments: the object, the @@ -227,13 +201,7 @@ ;; ALWAYS be available. So they've been moved from cl.el to eval.c. ;; Note: FSF Emacs moved them to subr.el in FSF 20. -(defun cl-map-extents (&rest cl-args) - ;; XEmacs: This used to check for overlays first, but that's wrong - ;; because of the new compatibility library. *duh* - (cond ((fboundp 'map-extents) - (apply 'map-extents cl-args)) - ((fboundp 'next-overlay-at) - (apply 'cl-map-overlays cl-args)))) +(defalias 'cl-map-extents 'map-extents) ;;; Blocks and exits. @@ -246,12 +214,40 @@ ;;; simulated. Instead, multiple-value-bind and friends simply expect ;;; the target form to return the values as a list. -(defalias 'values 'list) -(defalias 'values-list 'identity) -(defalias 'multiple-value-list 'identity) +(defsubst values (&rest values) + "Return multiple values, Common Lisp style. +The arguments of `values' are the values +that the containing function should return." + values) + +(defsubst values-list (list) + "Return multiple values, Common Lisp style, taken from a list. +LIST specifies the list of values +that the containing function should return." + list) + +(defsubst multiple-value-list (expression) + "Return a list of the multiple values produced by EXPRESSION. +This handles multiple values in Common Lisp style, but it does not +work right when EXPRESSION calls an ordinary Emacs Lisp function +that returns just one value." + expression) + +(defsubst multiple-value-apply (function expression) + "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them. +This handles multiple values in Common Lisp style, but it does not work +right when EXPRESSION calls an ordinary Emacs Lisp function that returns just +one value." + (apply function expression)) + (defalias 'multiple-value-call 'apply) ; only works for one arg -(defalias 'nth-value 'nth) +(defsubst nth-value (n expression) + "Evaluate EXPRESSION to get multiple values and return the Nth one. +This handles multiple values in Common Lisp style, but it does not work +right when EXPRESSION calls an ordinary Emacs Lisp function that returns just +one value." + (nth n expression)) ;;; Macros. @@ -317,6 +313,7 @@ (defvar *gensym-counter* (* (logand (cl-random-time) 1023) 100)) +;; XEmacs change: gensym and gentemp moved here from cl-macs.el (defun gensym (&optional arg) "Generate a new uninterned symbol. The name is made by appending a number to a prefix. If ARG is a string, it @@ -341,6 +338,8 @@ ;;; Numbers. +;; XEmacs change: use floatp, which is right even in the presence of ratios +;; and bigfloats (defun floatp-safe (object) "Return t if OBJECT is a floating point number." (floatp object)) @@ -361,14 +360,13 @@ "Return t if INTEGER is even." (eq (logand integer 1) 0)) -(defun cl-abs (number) - "Return the absolute value of NUMBER." - (if (>= number 0) number (- number))) -(or (fboundp 'abs) (defalias 'abs 'cl-abs)) ; This is built-in to Emacs 19 +;; XEmacs addition +(defalias 'cl-abs 'abs) (defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time))) -;; These constants are defined in C when 'number-types is provided. +;; XEmacs: These constants are defined in C when 'number-types is provided. +;; They are always defined in C on Emacs. Maybe we should, too. (unless (featurep 'number-types) ;;; We use `eval' in case VALBITS differs from compile-time to load-time. (defconst most-positive-fixnum (eval '(lsh -1 -1)) @@ -410,6 +408,7 @@ (nreverse cl-res))) (mapcar cl-func cl-x))) +(defalias 'svref 'aref) ;;; List functions. @@ -420,42 +419,44 @@ (defalias 'rest 'cdr) (defalias 'endp 'null) +;; XEmacs change: make it a real function (defun second (x) "Return the second element of the list LIST." (car (cdr x))) (defun third (x) - "Return the third element of the list LIST." + "Return the third element of the list X." (car (cdr (cdr x)))) (defun fourth (x) - "Return the fourth element of the list LIST." + "Return the fourth element of the list X." (nth 3 x)) (defun fifth (x) - "Return the fifth element of the list LIST." + "Return the fifth element of the list X." (nth 4 x)) (defun sixth (x) - "Return the sixth element of the list LIST." + "Return the sixth element of the list X." (nth 5 x)) (defun seventh (x) - "Return the seventh element of the list LIST." + "Return the seventh element of the list X." (nth 6 x)) (defun eighth (x) - "Return the eighth element of the list LIST." + "Return the eighth element of the list X." (nth 7 x)) (defun ninth (x) - "Return the ninth element of the list LIST." + "Return the ninth element of the list X." (nth 8 x)) (defun tenth (x) - "Return the tenth element of the list LIST." + "Return the tenth element of the list X." (nth 9 x)) +;; XEmacs change: Emacs defines caar, cadr, cdar, and cddr in subr.el. (defun caar (x) "Return the `car' of the `car' of X." (car (car x))) @@ -569,34 +570,16 @@ (cdr (cdr (cdr (cdr x))))) ;;; `last' is implemented as a C primitive, as of 1998-11 - -;(defun last (x &optional n) -; "Return the last link in the list LIST. -;With optional argument N, return Nth-to-last link (default 1)." -; (if n -; (let ((m 0) (p x)) -; (while (consp p) (incf m) (pop p)) -; (if (<= n 0) p -; (if (< n m) (nthcdr (- m n) x) x))) -; (while (consp (cdr x)) (pop x)) -; x)) - -;;; `butlast' is implemented as a C primitive, as of 1998-11 -;;; `nbutlast' is implemented as a C primitive, as of 1998-11 - -;(defun butlast (x &optional n) -; "Return a copy of LIST with the last N elements removed." -; (if (and n (<= n 0)) x -; (nbutlast (copy-sequence x) n))) - -;(defun nbutlast (x &optional n) -; "Modify LIST to remove the last N elements." -; (let ((m (length x))) -; (or n (setq n 1)) -; (and (< n m) -; (progn -; (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil)) -; x)))) +;;(defun last* (x &optional n) +;; "Returns the last link in the list LIST. +;;With optional argument N, returns Nth-to-last link (default 1)." +;; (if n +;; (let ((m 0) (p x)) +;; (while (consp p) (incf m) (pop p)) +;; (if (<= n 0) p +;; (if (< n m) (nthcdr (- m n) x) x))) +;; (while (consp (cdr x)) (pop x)) +;; x)) (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el "Return a new list with specified args as elements, cons'd to last arg. @@ -632,10 +615,6 @@ (while (and list (not (equal item (car list)))) (setq list (cdr list))) list) -;;; Define an Emacs 19-compatible `member' for the benefit of Emacs 18 users. -(or (and (fboundp 'member) (subrp (symbol-function 'member))) - (defalias 'member 'cl-maclisp-member)) - (defalias 'cl-member 'memq) ; for compatibility with old CL package (defalias 'cl-floor 'floor*) (defalias 'cl-ceiling 'ceiling*) @@ -683,19 +662,7 @@ ;; XEmacs change (define-error 'cl-assertion-failed "Assertion failed") -;;; This is defined in Emacs 19; define it here for Emacs 18 users. -(defun cl-add-hook (hook func &optional append) - "Add to hook variable HOOK the function FUNC. -FUNC is not added if it already appears on the list stored in HOOK." - (let ((old (and (boundp hook) (symbol-value hook)))) - (and (listp old) (not (eq (car old) 'lambda)) - (setq old (list old))) - (and (not (member func old)) - (set hook (if append (nconc old (list func)) (cons func old)))))) -(or (fboundp 'add-hook) (defalias 'add-hook 'cl-add-hook)) - -;; XEmacs change -;(load "cl-defs") +;; XEmacs change: omit the autoload rules; we handle those a different way ;;; Define data for indentation and edebug. (mapcar @@ -751,10 +718,10 @@ (defun cl-hack-byte-compiler () (if (and (not cl-hacked-flag) (fboundp 'byte-compile-file-form)) (progn + (setq cl-hacked-flag t) ; Do it first, to prevent recursion. (when (not (fboundp 'cl-compile-time-init)) (load "cl-macs" nil t)) - (cl-compile-time-init) ; in cl-macs.el - (setq cl-hacked-flag t)))) + (cl-compile-time-init)))) ; In cl-macs.el. ;;; Try it now in case the compiler has already been loaded. (cl-hack-byte-compiler) @@ -764,7 +731,8 @@ ;;; we can take advantage of the fact that emacs-lisp-mode will be ;;; called when the compiler reads in the file to be compiled. ;;; BUG: If the first compilation is `byte-compile' rather than -;;; `byte-compile-file', we lose. Oh, well. +;;; `byte-compile-file', we lose. Emacs has fixed this by hanging it +;;; on `bytecomp-load-hook' instead, which we do not have. (add-hook 'emacs-lisp-mode-hook 'cl-hack-byte-compiler) @@ -773,8 +741,7 @@ (provide 'cl) -(provide 'mini-cl) ; for Epoch - (run-hooks 'cl-load-hook) +;;; arch-tag: 5f07fa74-f153-4524-9303-21f5be125851 ;;; cl.el ends here