Mercurial > hg > xemacs-beta

comparison lisp/cl.el @ 5285:99de5fd48e87

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff lisp/ChangeLog addition: 2010-10-14 Aidan Kehoe <kehoea@parhasard.net> * byte-optimize.el (side-effect-free-fns): * cl-macs.el (remf, getf): * cl-extra.el (tailp, cl-set-getf, cl-do-remf): * cl.el (ldiff, endp): Tighten up Common Lisp compatibility for #'ldiff, #'endp, #'tailp; add circularity checking for the first two. #'cl-set-getf and #'cl-do-remf were Lisp implementations of #'plist-put and #'plist-remprop; change the names to aliases, changes the macros that use them to using #'plist-put and #'plist-remprop directly. src/ChangeLog addition: 2010-10-14 Aidan Kehoe <kehoea@parhasard.net> * fns.c (Fnbutlast, Fbutlast): Tighten up Common Lisp compatibility for these two functions; they need to operate on dotted lists without erroring. tests/ChangeLog addition: 2010-10-14 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el (x): Test #'nbutlast, #'butlast with dotted lists. Check that #'ldiff and #'tailp don't hang on circular lists; check that #'tailp returns t with circular lists when that is appropriate. Test them both with dotted lists.
author Aidan Kehoe <kehoea@parhasard.net>
date Thu, 14 Oct 2010 18:50:38 +0100
parents aa20a889ff14
children bbff29a01820
comparison
equal deleted inserted replaced
5284:d27c1ee1943b 5285:99de5fd48e87
363 ;; 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
364 ;; and turned into efficient car and cdr bytecodes. 364 ;; and turned into efficient car and cdr bytecodes.
365 365
366 (defalias 'first 'car) 366 (defalias 'first 'car)
367 (defalias 'rest 'cdr) 367 (defalias 'rest 'cdr)
368 (defalias 'endp 'null) 368
369 ;; XEmacs change; this needs to error if handed a non-list.
370 (defun endp (list)
371 "Return t if LIST is nil, or nil if LIST is a cons. Error otherwise."
372 (prog1
373 (null list)
374 (and list (atom list) (error 'wrong-type-argument #'listp list))))
369 375
370 ;; XEmacs change: make it a real function 376 ;; XEmacs change: make it a real function
371 (defun second (x) 377 (defun second (x)
372 "Return the second element of the list LIST." 378 "Return the second element of the list LIST."
373 (car (cdr x))) 379 (car (cdr x)))
519 525
520 ;;; `last' is implemented as a C primitive, as of 1998-11 526 ;;; `last' is implemented as a C primitive, as of 1998-11
521 527
522 ;;; XEmacs: `list*' is in subr.el. 528 ;;; XEmacs: `list*' is in subr.el.
523 529
530 ;; XEmacs; handle dotted lists properly, error on circularity and if LIST is
531 ;; not a list.
524 (defun ldiff (list sublist) 532 (defun ldiff (list sublist)
525 "Return a copy of LIST with the tail SUBLIST removed." 533 "Return a copy of LIST with the tail SUBLIST removed.
526 (let ((res nil)) 534
527 (while (and (consp list) (not (eq list sublist))) 535 If SUBLIST is the same Lisp object as LIST, return nil. If SUBLIST is
528 (push (pop list) res)) 536 not present in the list structure of LIST (that is, it is not the cdr
529 (nreverse res))) 537 of some cons making up LIST), this function is equivalent to
538 `copy-list'. LIST may be dotted."
539 (check-argument-type #'listp list)
540 (and list (not (eq list sublist))
541 (let ((before list) (evenp t) result)
542 (prog1
543 (setq result (list (car list)))
544 (while (and (setq list (cdr-safe list)) (not (eql list sublist)))
545 (setf (cdr result) (if (consp list) (list (car list)) list)
546 result (cdr result)
547 evenp (not evenp))
548 (if evenp (setq before (cdr before)))
549 (if (eq before list) (error 'circular-list list)))))))
530 550
531 ;;; `copy-list' is implemented as a C primitive, as of 1998-11 551 ;;; `copy-list' is implemented as a C primitive, as of 1998-11
532 552
533 (defalias 'cl-member 'memq) ; for compatibility with old CL package 553 (defalias 'cl-member 'memq) ; for compatibility with old CL package
534 (defalias 'cl-floor 'floor*) 554 (defalias 'cl-floor 'floor*)