Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.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 d27c1ee1943b
children 09fed7053634 b9167d522a9a
comparison
equal deleted inserted replaced
5284:d27c1ee1943b 5285:99de5fd48e87
403 403
404 (defun nreconc (x y) 404 (defun nreconc (x y)
405 "Equivalent to (nconc (nreverse X) Y)." 405 "Equivalent to (nconc (nreverse X) Y)."
406 (nconc (nreverse x) y)) 406 (nconc (nreverse x) y))
407 407
408 ;; XEmacs; check LIST for type and circularity.
408 (defun tailp (sublist list) 409 (defun tailp (sublist list)
409 "Return true if SUBLIST is a tail of LIST." 410 "Return true if SUBLIST is a tail of LIST."
410 (while (and (consp list) (not (eq sublist list))) 411 (check-argument-type #'listp list)
411 (setq list (cdr list))) 412 (let ((before list) (evenp t))
412 (if (numberp sublist) (equal sublist list) (eq sublist list))) 413 (while (and (consp list) (not (eq sublist list)))
414 (setq list (cdr list)
415 evenp (not evenp))
416 (if evenp (setq before (cdr before)))
417 (if (eq before list) (error 'circular-list list)))
418 (eql sublist list)))
413 419
414 (defalias 'cl-copy-tree 'copy-tree) 420 (defalias 'cl-copy-tree 'copy-tree)
415 421
416 ;;; Property lists. 422 ;;; Property lists.
417 423
418 ;; XEmacs: our `get' groks DEFAULT. 424 ;; XEmacs: our `get' groks DEFAULT.
419 (defalias 'get* 'get) 425 (defalias 'get* 'get)
420 (defalias 'getf 'plist-get) 426 (defalias 'getf 'plist-get)
421 427
422 (defun cl-set-getf (plist tag val) 428 ;; XEmacs; these are built-in.
423 (let ((p plist)) 429 (defalias 'cl-set-getf 'plist-put)
424 (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) 430 (defalias 'cl-do-remf 'plist-remprop)
425 (if p (progn (setcar (cdr p) val) plist) (list* tag val plist))))
426
427 (defun cl-do-remf (plist tag)
428 (let ((p (cdr plist)))
429 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
430 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
431
432 ;; XEmacs change: we have a builtin remprop
433 (defalias 'cl-remprop 'remprop) 431 (defalias 'cl-remprop 'remprop)
434 432
435 (defun get-properties (plist indicator-list) 433 (defun get-properties (plist indicator-list)
436 "Find a property from INDICATOR-LIST in PLIST. 434 "Find a property from INDICATOR-LIST in PLIST.
437 Return 3 values: 435 Return 3 values: