Mercurial > hg > xemacs-beta

comparison lisp/cl.el @ 380:8626e4521993 r21-2-5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-5
author cvs
date Mon, 13 Aug 2007 11:07:10 +0200
parents cc15677e0335
children 74fd4e045ea6
comparison
equal deleted inserted replaced
379:76b7d63099ad 380:8626e4521993
181 "(pop PLACE): remove and return the head of the list stored in PLACE. 181 "(pop PLACE): remove and return the head of the list stored in PLACE.
182 Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more 182 Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more
183 careful about evaluating each argument only once and in the right order. 183 careful about evaluating each argument only once and in the right order.
184 PLACE may be a symbol, or any generalized variable allowed by `setf'." 184 PLACE may be a symbol, or any generalized variable allowed by `setf'."
185 (if (symbolp place) 185 (if (symbolp place)
186 (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) 186 `(car (prog1 ,place (setq ,place (cdr ,place))))
187 (cl-do-pop place))) 187 (cl-do-pop place)))
188 188
189 (defmacro push (x place) 189 (defmacro push (x place)
190 "(push X PLACE): insert X at the head of the list stored in PLACE. 190 "(push X PLACE): insert X at the head of the list stored in PLACE.
191 Analogous to (setf PLACE (cons X PLACE)), though more careful about 191 Analogous to (setf PLACE (cons X PLACE)), though more careful about
192 evaluating each argument only once and in the right order. PLACE may 192 evaluating each argument only once and in the right order. PLACE may
193 be a symbol, or any generalized variable allowed by `setf'." 193 be a symbol, or any generalized variable allowed by `setf'."
194 (if (symbolp place) (list 'setq place (list 'cons x place)) 194 (if (symbolp place) `(setq ,place (cons ,x ,place))
195 (list 'callf2 'cons x place))) 195 (list 'callf2 'cons x place)))
196 196
197 (defmacro pushnew (x place &rest keys) 197 (defmacro pushnew (x place &rest keys)
198 "(pushnew X PLACE): insert X at the head of the list if not already there. 198 "(pushnew X PLACE): insert X at the head of the list if not already there.
199 Like (push X PLACE), except that the list is unmodified if X is `eql' to 199 Like (push X PLACE), except that the list is unmodified if X is `eql' to
223 (and (< end (length str)) (substring str end)))) 223 (and (< end (length str)) (substring str end))))
224 224
225 225
226 ;;; Control structures. 226 ;;; Control structures.
227 227
228 ;; These macros are so simple and so often-used that it's better to have 228 ;; The macros `when' and `unless' are so useful that we want them to
229 ;; them all the time than to load them from cl-macs.el. 229 ;; ALWAYS be available. So they've been moved from cl.el to eval.c.
230 230 ;; Note: FSF Emacs moved them to subr.el in FSF 20.
231 ;; NOTE: these macros were moved to subr.el in FSF 20. It is of no
232 ;; consequence to XEmacs, because we preload this file, and they
233 ;; should better remain here.
234
235 (defmacro when (cond &rest body)
236 "(when COND BODY...): if COND yields non-nil, do BODY, else return nil."
237 (list 'if cond (cons 'progn body)))
238
239 (defmacro unless (cond &rest body)
240 "(unless COND BODY...): if COND yields nil, do BODY, else return nil."
241 (cons 'if (cons cond (cons nil body))))
242 231
243 (defun cl-map-extents (&rest cl-args) 232 (defun cl-map-extents (&rest cl-args)
244 ;; XEmacs: This used to check for overlays first, but that's wrong 233 ;; XEmacs: This used to check for overlays first, but that's wrong
245 ;; because of the new compatibility library. *duh* 234 ;; because of the new compatibility library. *duh*
246 (cond ((fboundp 'map-extents) 235 (cond ((fboundp 'map-extents)
404 (mapcar cl-func cl-x))) 393 (mapcar cl-func cl-x)))
405 394
406 395
407 ;;; List functions. 396 ;;; List functions.
408 397
398 ;; These functions are made known to the byte-compiler by cl-macs.el
399 ;; and turned into efficient car and cdr bytecodes.
400
409 (defalias 'first 'car) 401 (defalias 'first 'car)
410 (defalias 'rest 'cdr) 402 (defalias 'rest 'cdr)
411 (defalias 'endp 'null) 403 (defalias 'endp 'null)
412 404
413 (defun second (x) 405 (defun second (x)
556 548
557 (defun cddddr (x) 549 (defun cddddr (x)
558 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." 550 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
559 (cdr (cdr (cdr (cdr x))))) 551 (cdr (cdr (cdr (cdr x)))))
560 552
561 (defun last (x &optional n) 553 ;;; `last' is implemented as a C primitive, as of 1998-11
562 "Return the last link in the list LIST. 554
563 With optional argument N, return Nth-to-last link (default 1)." 555 ;(defun last (x &optional n)
564 (if n 556 ; "Return the last link in the list LIST.
565 (let ((m 0) (p x)) 557 ;With optional argument N, return Nth-to-last link (default 1)."
566 (while (consp p) (incf m) (pop p)) 558 ; (if n
567 (if (<= n 0) p 559 ; (let ((m 0) (p x))
568 (if (< n m) (nthcdr (- m n) x) x))) 560 ; (while (consp p) (incf m) (pop p))
569 (while (consp (cdr x)) (pop x)) 561 ; (if (<= n 0) p
570 x)) 562 ; (if (< n m) (nthcdr (- m n) x) x)))
571 563 ; (while (consp (cdr x)) (pop x))
572 (defun butlast (x &optional n) 564 ; x))
573 "Return a copy of LIST with the last N elements removed." 565
574 (if (and n (<= n 0)) x 566 ;;; `butlast' is implemented as a C primitive, as of 1998-11
575 (nbutlast (copy-sequence x) n))) 567 ;;; `nbutlast' is implemented as a C primitive, as of 1998-11
576 568
577 (defun nbutlast (x &optional n) 569 ;(defun butlast (x &optional n)
578 "Modify LIST to remove the last N elements." 570 ; "Return a copy of LIST with the last N elements removed."
579 (let ((m (length x))) 571 ; (if (and n (<= n 0)) x
580 (or n (setq n 1)) 572 ; (nbutlast (copy-sequence x) n)))
581 (and (< n m) 573
582 (progn 574 ;(defun nbutlast (x &optional n)
583 (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil)) 575 ; "Modify LIST to remove the last N elements."
584 x)))) 576 ; (let ((m (length x)))
577 ; (or n (setq n 1))
578 ; (and (< n m)
579 ; (progn
580 ; (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
581 ; x))))
585 582
586 (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el 583 (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el
587 "Return a new list with specified args as elements, cons'd to last arg. 584 "Return a new list with specified args as elements, cons'd to last arg.
588 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to 585 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
589 `(cons A (cons B (cons C D)))'." 586 `(cons A (cons B (cons C D)))'."
600 (let ((res nil)) 597 (let ((res nil))
601 (while (and (consp list) (not (eq list sublist))) 598 (while (and (consp list) (not (eq list sublist)))
602 (push (pop list) res)) 599 (push (pop list) res))
603 (nreverse res))) 600 (nreverse res)))
604 601
605 (defun copy-list (list) 602 ;;; `copy-list' is implemented as a C primitive, as of 1998-11
606 "Return a copy of a list, which may be a dotted list. 603
607 The elements of the list are not copied, just the list structure itself." 604 ;(defun copy-list (list)
608 (if (consp list) 605 ; "Return a copy of a list, which may be a dotted list.
609 (let ((res nil)) 606 ;The elements of the list are not copied, just the list structure itself."
610 (while (consp list) (push (pop list) res)) 607 ; (if (consp list)
611 (prog1 (nreverse res) (setcdr res list))) 608 ; (let ((res nil))
612 (car list))) 609 ; (while (consp list) (push (pop list) res))
610 ; (prog1 (nreverse res) (setcdr res list)))
611 ; (car list)))
613 612
614 (defun cl-maclisp-member (item list) 613 (defun cl-maclisp-member (item list)
615 (while (and list (not (equal item (car list)))) (setq list (cdr list))) 614 (while (and list (not (equal item (car list)))) (setq list (cdr list)))
616 list) 615 list)
617 616
679 678
680 ;; XEmacs change 679 ;; XEmacs change
681 ;(load "cl-defs") 680 ;(load "cl-defs")
682 681
683 ;;; Define data for indentation and edebug. 682 ;;; Define data for indentation and edebug.
684 (mapcar (function 683 (mapc
685 (lambda (entry) 684 #'(lambda (entry)
686 (mapcar (function 685 (mapc
687 (lambda (func) 686 #'(lambda (func)
688 (put func 'lisp-indent-function (nth 1 entry)) 687 (put func 'lisp-indent-function (nth 1 entry))
689 (put func 'lisp-indent-hook (nth 1 entry)) 688 (put func 'lisp-indent-hook (nth 1 entry))
690 (or (get func 'edebug-form-spec) 689 (or (get func 'edebug-form-spec)
691 (put func 'edebug-form-spec (nth 2 entry))))) 690 (put func 'edebug-form-spec (nth 2 entry))))
692 (car entry)))) 691 (car entry)))
693 '(((defun* defmacro*) defun) 692 '(((defun* defmacro*) defun)
694 ((function*) nil 693 ((function*) nil
695 (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) 694 (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form)))
696 ((eval-when) 1 (sexp &rest form)) 695 ((eval-when) 1 (sexp &rest form))
697 ((when unless) 1 (&rest form)) 696 ((when unless) 1 (&rest form))
698 ((declare) nil (&rest sexp)) 697 ((declare) nil (&rest sexp))
699 ((the) 1 (sexp &rest form)) 698 ((the) 1 (sexp &rest form))
700 ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form))) 699 ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form)))
701 ((block return-from) 1 (sexp &rest form)) 700 ((block return-from) 1 (sexp &rest form))
702 ((return) nil (&optional form)) 701 ((return) nil (&optional form))
703 ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form)) 702 ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form))
704 (form &rest form) 703 (form &rest form)
705 &rest form)) 704 &rest form))
706 ((dolist dotimes) 1 ((symbolp form &rest form) &rest form)) 705 ((dolist dotimes) 1 ((symbolp form &rest form) &rest form))
707 ((do-symbols) 1 ((symbolp form &optional form form) &rest form)) 706 ((do-symbols) 1 ((symbolp form &optional form form) &rest form))
708 ((do-all-symbols) 1 ((symbolp form &optional form) &rest form)) 707 ((do-all-symbols) 1 ((symbolp form &optional form) &rest form))
709 ((psetq setf psetf) nil edebug-setq-form) 708 ((psetq setf psetf) nil edebug-setq-form)
710 ((progv) 2 (&rest form)) 709 ((progv) 2 (&rest form))
711 ((flet labels macrolet) 1 710 ((flet labels macrolet) 1
712 ((&rest (sexp sexp &rest form)) &rest form)) 711 ((&rest (sexp sexp &rest form)) &rest form))
713 ((symbol-macrolet lexical-let lexical-let*) 1 712 ((symbol-macrolet lexical-let lexical-let*) 1
714 ((&rest &or symbolp (symbolp form)) &rest form)) 713 ((&rest &or symbolp (symbolp form)) &rest form))
715 ((multiple-value-bind) 2 ((&rest symbolp) &rest form)) 714 ((multiple-value-bind) 2 ((&rest symbolp) &rest form))
716 ((multiple-value-setq) 1 ((&rest symbolp) &rest form)) 715 ((multiple-value-setq) 1 ((&rest symbolp) &rest form))
717 ((incf decf remf pop push pushnew shiftf rotatef) nil (&rest form)) 716 ((incf decf remf pop push pushnew shiftf rotatef) nil (&rest form))
718 ((letf letf*) 1 ((&rest (&rest form)) &rest form)) 717 ((letf letf*) 1 ((&rest (&rest form)) &rest form))
719 ((callf destructuring-bind) 2 (sexp form &rest form)) 718 ((callf destructuring-bind) 2 (sexp form &rest form))
720 ((callf2) 3 (sexp form form &rest form)) 719 ((callf2) 3 (sexp form form &rest form))
721 ((loop) defun (&rest &or symbolp form)) 720 ((loop) defun (&rest &or symbolp form))
722 ((ignore-errors) 0 (&rest form)))) 721 ((ignore-errors) 0 (&rest form))))
723 722
724 723
725 ;;; This goes here so that cl-macs can find it if it loads right now. 724 ;;; This goes here so that cl-macs can find it if it loads right now.
726 (provide 'cl-19) ; usage: (require 'cl-19 "cl") 725 (provide 'cl-19) ; usage: (require 'cl-19 "cl")
727 726