Mercurial > hg > xemacs-beta

comparison lisp/cl.el @ 5219:2d0937dc83cf

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Tidying of CL files; make docstrings read better, remove commented-out code 2010-05-30 Aidan Kehoe <kehoea@parhasard.net> * cl.el: Remove extraneous empty lines. Remove the commented-out Lisp implementation of #'last, #'copy-list. Remove #'cl-maclisp-member. (acons, pairlis): Have the argument list reflect the docstring for these functions. * cl-macs.el (defun*): Have the argument list reflect the docstring. Document the syntax of keywords in ARGLIST. (defmacro*): Have the argument list reflect the docstring. Document &body, &whole and &environment. (function*): Have the argument list reflect the docstring. (loop): Have the argument list reflect the docstring. (eval-when, dolist, dotimes, do-symbols, flet, labels, macrolet, symbol-macrolet): Specify the argument list using the arguments: (...) syntax. (define-setf-method, rotatef, defsubst*): Have the argument list reflect the docstring. (letf, letf*): Specify the argument list using the arguments: (...) syntax. (svref, acons, pairlis): Add compiler macros for these functions. * cl-extra.el: Remove the commented-out Lisp implementation of #'equalp. If we want to look at it, it's in version control. (cl-expt): Remove this. The subr #'expt is always available. Call #'cl-float-limits at dump time. Remove the commented-out Lisp implementation of #'subseq. (concatenate): Use (error 'invalid-argument ...) here, if TYPE is not understood. (list-length): Don't manually get the length of a list, call #'length and return nil if the list is circular. * byte-optimize.el (equalp): This needs byte-optimize-binary-predicate as its optimizer, as do the other equality predicates.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 30 May 2010 13:27:36 +0100
parents 545ec923b4eb
children aa20a889ff14 308d34e9f07d
comparison
equal deleted inserted replaced
5218:ec2ddc82f10d 5219:2d0937dc83cf
97 ;; * First public release of this package. 97 ;; * First public release of this package.
98 98
99 99
100 ;;; Code: 100 ;;; Code:
101 101
102 (defvar cl-emacs-type (cond ((or (and (fboundp 'epoch::version)
103 (symbol-value 'epoch::version))
104 (string-lessp emacs-version "19")) 18)
105 ((string-match "XEmacs" emacs-version)
106 'lucid)
107 (t 19)))
108
109 (defvar cl-optimize-speed 1) 102 (defvar cl-optimize-speed 1)
110 (defvar cl-optimize-safety 1) 103 (defvar cl-optimize-safety 1)
111
112 104
113 (defvar custom-print-functions nil 105 (defvar custom-print-functions nil
114 "This is a list of functions that format user objects for printing. 106 "This is a list of functions that format user objects for printing.
115 Each function is called in turn with three arguments: the object, the 107 Each function is called in turn with three arguments: the object, the
116 stream, and the print level (currently ignored). If it is able to 108 stream, and the print level (currently ignored). If it is able to
117 print the object it returns true; otherwise it returns nil and the 109 print the object it returns true; otherwise it returns nil and the
118 printer proceeds to the next function on the list. 110 printer proceeds to the next function on the list.
119 111
120 This variable is not used at present, but it is defined in hopes that 112 This variable is not used at present, but it is defined in hopes that
121 a future Emacs interpreter will be able to use it.") 113 a future Emacs interpreter will be able to use it.")
122
123 114
124 ;;; Predicates. 115 ;;; Predicates.
125 116
126 (defun eql (a b) ; See compiler macro in cl-macs.el 117 (defun eql (a b) ; See compiler macro in cl-macs.el
127 "Return t if the arguments are the same Lisp object, or numerically equal. 118 "Return t if the arguments are the same Lisp object, or numerically equal.
204 (if (< start 0) (incf start (length str))) 195 (if (< start 0) (incf start (length str)))
205 (concat (and (> start 0) (substring str 0 start)) 196 (concat (and (> start 0) (substring str 0 start))
206 val 197 val
207 (and (< end (length str)) (substring str end)))) 198 (and (< end (length str)) (substring str end))))
208 199
209
210 ;;; Control structures. 200 ;;; Control structures.
211 201
212 ;; The macros `when' and `unless' are so useful that we want them to 202 ;; The macros `when' and `unless' are so useful that we want them to
213 ;; ALWAYS be available. So they've been moved from cl.el to eval.c. 203 ;; ALWAYS be available. So they've been moved from cl.el to eval.c.
214 ;; Note: FSF Emacs moved them to subr.el in FSF 20. 204 ;; Note: FSF Emacs moved them to subr.el in FSF 20.
215 205
216 (defalias 'cl-map-extents 'map-extents) 206 (defalias 'cl-map-extents 'map-extents)
217
218 207
219 ;;; Blocks and exits. 208 ;;; Blocks and exits.
220 209
221 ;; This used to be #'identity, but that didn't preserve multiple values in 210 ;; This used to be #'identity, but that didn't preserve multiple values in
222 ;; interpreted code. #'and isn't great either, there's no error on too many 211 ;; interpreted code. #'and isn't great either, there's no error on too many
257 (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env)) 246 (while (progn (setq cl-macro (funcall cl-old-macroexpand cl-macro cl-env))
258 (and (symbolp cl-macro) 247 (and (symbolp cl-macro)
259 (cdr (assq (symbol-name cl-macro) cl-env)))) 248 (cdr (assq (symbol-name cl-macro) cl-env))))
260 (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env)))) 249 (setq cl-macro (cadr (assq (symbol-name cl-macro) cl-env))))
261 cl-macro)) 250 cl-macro))
262
263 251
264 ;;; Declarations. 252 ;;; Declarations.
265 253
266 (defvar cl-compiling-file nil) 254 (defvar cl-compiling-file nil)
267 (defun cl-compiling-file () 255 (defun cl-compiling-file ()
286 (defmacro declaim (&rest specs) 274 (defmacro declaim (&rest specs)
287 (let ((body (mapcar (function (lambda (x) (list 'proclaim (list 'quote x)))) 275 (let ((body (mapcar (function (lambda (x) (list 'proclaim (list 'quote x))))
288 specs))) 276 specs)))
289 (if (cl-compiling-file) (list* 'eval-when '(compile load eval) body) 277 (if (cl-compiling-file) (list* 'eval-when '(compile load eval) body)
290 (cons 'progn body)))) ; avoid loading cl-macs.el for eval-when 278 (cons 'progn body)))) ; avoid loading cl-macs.el for eval-when
291
292 279
293 ;;; Symbols. 280 ;;; Symbols.
294 281
295 (defun cl-random-time () 282 (defun cl-random-time ()
296 (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) 283 (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
361 (defconst least-positive-normalized-float nil) 348 (defconst least-positive-normalized-float nil)
362 (defconst least-negative-normalized-float nil) 349 (defconst least-negative-normalized-float nil)
363 (defconst float-epsilon nil) 350 (defconst float-epsilon nil)
364 (defconst float-negative-epsilon nil) 351 (defconst float-negative-epsilon nil)
365 352
366
367 ;;; Sequence functions. 353 ;;; Sequence functions.
368 354
369 (defalias 'copy-seq 'copy-sequence) 355 (defalias 'copy-seq 'copy-sequence)
370 356
371 (defalias 'svref 'aref) 357 ;; XEmacs; #'mapcar* is in C.
358
359 (defalias 'svref 'aref) ;; Compiler macro in cl-macs.el
372 360
373 ;;; List functions. 361 ;;; List functions.
374 362
375 ;; These functions are made known to the byte-compiler by cl-macs.el 363 ;; These functions are made known to the byte-compiler by cl-macs.el
376 ;; and turned into efficient car and cdr bytecodes. 364 ;; and turned into efficient car and cdr bytecodes.
528 (defun cddddr (x) 516 (defun cddddr (x)
529 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." 517 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
530 (cdr (cdr (cdr (cdr x))))) 518 (cdr (cdr (cdr (cdr x)))))
531 519
532 ;;; `last' is implemented as a C primitive, as of 1998-11 520 ;;; `last' is implemented as a C primitive, as of 1998-11
533 ;;(defun last* (x &optional n)
534 ;; "Returns the last link in the list LIST.
535 ;;With optional argument N, returns Nth-to-last link (default 1)."
536 ;; (if n
537 ;; (let ((m 0) (p x))
538 ;; (while (consp p) (incf m) (pop p))
539 ;; (if (<= n 0) p
540 ;; (if (< n m) (nthcdr (- m n) x) x)))
541 ;; (while (consp (cdr x)) (pop x))
542 ;; x))
543 521
544 (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el 522 (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el
545 "Return a new list with specified args as elements, cons'd to last arg. 523 "Return a new list with specified args as elements, cons'd to last arg.
546 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to 524 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
547 `(cons A (cons B (cons C D)))'." 525 `(cons A (cons B (cons C D)))'."
560 (push (pop list) res)) 538 (push (pop list) res))
561 (nreverse res))) 539 (nreverse res)))
562 540
563 ;;; `copy-list' is implemented as a C primitive, as of 1998-11 541 ;;; `copy-list' is implemented as a C primitive, as of 1998-11
564 542
565 ;(defun copy-list (list)
566 ; "Return a copy of a list, which may be a dotted list.
567 ;The elements of the list are not copied, just the list structure itself."
568 ; (if (consp list)
569 ; (let ((res nil))
570 ; (while (consp list) (push (pop list) res))
571 ; (prog1 (nreverse res) (setcdr res list)))
572 ; (car list)))
573
574 (defun cl-maclisp-member (item list)
575 (while (and list (not (equal item (car list)))) (setq list (cdr list)))
576 list)
577
578 (defalias 'cl-member 'memq) ; for compatibility with old CL package 543 (defalias 'cl-member 'memq) ; for compatibility with old CL package
579 (defalias 'cl-floor 'floor*) 544 (defalias 'cl-floor 'floor*)
580 (defalias 'cl-ceiling 'ceiling*) 545 (defalias 'cl-ceiling 'ceiling*)
581 (defalias 'cl-truncate 'truncate*) 546 (defalias 'cl-truncate 'truncate*)
582 (defalias 'cl-round 'round*) 547 (defalias 'cl-round 'round*)
610 (d (cl-do-subst cl-new cl-old (cdr cl-tree)))) 575 (d (cl-do-subst cl-new cl-old (cdr cl-tree))))
611 (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree))) 576 (if (and (eq a (car cl-tree)) (eq d (cdr cl-tree)))
612 cl-tree (cons a d)))) 577 cl-tree (cons a d))))
613 (t cl-tree))) 578 (t cl-tree)))
614 579
615 (defun acons (a b c) 580 (defun acons (key value alist)
616 "Return a new alist created by adding (KEY . VALUE) to ALIST." 581 "Return a new alist created by adding (KEY . VALUE) to ALIST."
617 (cons (cons a b) c)) 582 (cons (cons key value) alist))
618 583
619 (defun pairlis (a b &optional c) (nconc (mapcar* 'cons a b) c)) 584 (defun pairlis (keys values &optional alist)
620 585 "Make an alist from KEYS and VALUES.
586 Return a new alist composed by associating KEYS to corresponding VALUES;
587 the process stops as soon as KEYS or VALUES run out.
588 If ALIST is non-nil, the new pairs are prepended to it."
589 (nconc (mapcar* 'cons keys values) alist))
621 590
622 ;;; Miscellaneous. 591 ;;; Miscellaneous.
623 592
624 ;; XEmacs change 593 ;; XEmacs change
625 (define-error 'cl-assertion-failed "Assertion failed") 594 (define-error 'cl-assertion-failed "Assertion failed")
665 ((callf destructuring-bind) 2 (sexp form &rest form)) 634 ((callf destructuring-bind) 2 (sexp form &rest form))
666 ((callf2) 3 (sexp form form &rest form)) 635 ((callf2) 3 (sexp form form &rest form))
667 ((loop) defun (&rest &or symbolp form)) 636 ((loop) defun (&rest &or symbolp form))
668 ((ignore-errors) 0 (&rest form)))) 637 ((ignore-errors) 0 (&rest form))))
669 638
670
671 ;;; This goes here so that cl-macs can find it if it loads right now. 639 ;;; This goes here so that cl-macs can find it if it loads right now.
672 (provide 'cl-19) ; usage: (require 'cl-19 "cl") 640 (provide 'cl-19)
673
674 641
675 ;;; Things to do after byte-compiler is loaded. 642 ;;; Things to do after byte-compiler is loaded.
676 ;;; As a side effect, we cause cl-macs to be loaded when compiling, so 643 ;;; As a side effect, we cause cl-macs to be loaded when compiling, so
677 ;;; that the compiler-macros defined there will be present. 644 ;;; that the compiler-macros defined there will be present.
678 645