# HG changeset patch # User Aidan Kehoe # Date 1267534956 0 # Node ID 1ee30d3f9dd0ba716661dbebeb7ebf71d3eca3ba # Parent 6afe991b8135b3d41f91f58c2004ae9fb6b3d448 Handle the :from-end argument correctly, #'delete-duplicates compiler macro. 2010-03-02 Aidan Kehoe * cl-macs.el (delete-dups): New compiler macro for this function, expanding to inline byte codes. (delete-duplicates): Handle the :from-end argument correctly in this compiler macro. diff -r 6afe991b8135 -r 1ee30d3f9dd0 lisp/ChangeLog --- a/lisp/ChangeLog Mon Mar 01 21:05:33 2010 +0000 +++ b/lisp/ChangeLog Tue Mar 02 13:02:36 2010 +0000 @@ -1,3 +1,10 @@ +2010-03-02 Aidan Kehoe + + * cl-macs.el (delete-dups): New compiler macro for this function, + expanding to inline byte codes. + (delete-duplicates): Handle the :from-end argument correctly in + this compiler macro. + 2010-03-01 Aidan Kehoe * cl-seq.el (cl-parsing-keywords): diff -r 6afe991b8135 -r 1ee30d3f9dd0 lisp/cl-macs.el --- a/lisp/cl-macs.el Mon Mar 01 21:05:33 2010 +0000 +++ b/lisp/cl-macs.el Tue Mar 02 13:02:36 2010 +0000 @@ -3292,50 +3292,113 @@ (list 'let (list (list temp val)) (subst temp val res))))) form)) -;; XEmacs; inline delete-duplicates if it's called with a literal -;; #'equal or #'eq and no other keywords, we want the speed in -;; font-lock.el. +(define-compiler-macro delete-dups (list) + `(delete-duplicates (the list ,list) :test #'equal :from-end t)) + +;; XEmacs; inline delete-duplicates if it's called with one of the +;; common compile-time constant tests and an optional :from-end +;; argument, we want the speed in font-lock.el. (define-compiler-macro delete-duplicates (&whole form cl-seq &rest cl-keys) (let ((listp-check - (if (memq (car-safe cl-seq) - ;; No need to check for a list at runtime with these. We - ;; could expand the list, but these are all the functions - ;; in the relevant context at the moment. - '(nreverse append nconc mapcan mapcar)) - t - '(listp begin)))) - (cond ((and (= 4 (length form)) - (eq :test (third form)) - (or (equal '(quote eq) (fourth form)) - (equal '(function eq) (fourth form)))) + (cond + ((memq (car-safe cl-seq) + ;; No need to check for a list at runtime with these. We + ;; could expand the list, but these are all the functions + ;; in the relevant context at the moment. + '(nreverse append nconc mapcan mapcar string-to-list)) + t) + ((and (listp cl-seq) (eq (first cl-seq) 'the) + (eq (second cl-seq) 'list)) + ;; Allow users to force this, if they really want to. + t) + (t + '(listp begin))))) + (cond ((loop + for relevant-key-values + in '((:test 'eq) + (:test #'eq) + (:test 'eq :from-end nil) + (:test #'eq :from-end nil)) + ;; One of the above corresponds exactly to CL-KEYS: + thereis (not (set-difference cl-keys relevant-key-values + :test #'equal))) + `(let* ((begin ,cl-seq) + cl-seq) + (if ,listp-check + (progn + (while (memq (car begin) (cdr begin)) + (setq begin (cdr begin))) + (setq cl-seq begin) + (while (cddr cl-seq) + (if (memq (cadr cl-seq) (cddr cl-seq)) + (setcdr (cdr cl-seq) (cddr cl-seq)) + (setq cl-seq (cdr cl-seq)))) + begin) + ;; Call cl-delete-duplicates explicitly, to avoid the form + ;; getting compiler-macroexpanded again: + (cl-delete-duplicates begin ',cl-keys nil)))) + ((loop + for relevant-key-values + in '((:test 'eq :from-end t) + (:test #'eq :from-end t)) + ;; One of the above corresponds exactly to CL-KEYS: + thereis (not (set-difference cl-keys relevant-key-values + :test #'equal))) + `(let* ((begin ,cl-seq) + (cl-seq begin)) + (if ,listp-check + (progn + (while cl-seq + (setq cl-seq (setcdr cl-seq + (delq (car cl-seq) (cdr cl-seq))))) + begin) + ;; Call cl-delete-duplicates explicitly, to avoid the form + ;; getting compiler-macroexpanded again: + (cl-delete-duplicates begin ',cl-keys nil)))) + + ((loop + for relevant-key-values + in '((:test 'equal) + (:test #'equal) + (:test 'equal :from-end nil) + (:test #'equal :from-end nil)) + ;; One of the above corresponds exactly to CL-KEYS: + thereis (not (set-difference cl-keys relevant-key-values + :test #'equal))) + `(let* ((begin ,cl-seq) + cl-seq) + (if ,listp-check + (progn + (while (member (car begin) (cdr begin)) + (setq begin (cdr begin))) + (setq cl-seq begin) + (while (cddr cl-seq) + (if (member (cadr cl-seq) (cddr cl-seq)) + (setcdr (cdr cl-seq) (cddr cl-seq))) + (setq cl-seq (cdr cl-seq))) + begin) + ;; Call cl-delete-duplicates explicitly, to avoid the form + ;; getting compiler-macroexpanded again: + (cl-delete-duplicates begin ',cl-keys nil)))) + ((loop + for relevant-key-values + in '((:test 'equal :from-end t) + (:test #'equal :from-end t)) + ;; One of the above corresponds exactly to CL-KEYS: + thereis (not (set-difference cl-keys relevant-key-values + :test #'equal))) `(let* ((begin ,cl-seq) (cl-seq begin)) (if ,listp-check (progn (while cl-seq - (setq cl-seq (setcdr cl-seq (delq (car cl-seq) - (cdr cl-seq))))) - begin) + (setq cl-seq + (setcdr cl-seq (delete (car cl-seq) (cdr cl-seq))))) + begin) ;; Call cl-delete-duplicates explicitly, to avoid the form ;; getting compiler-macroexpanded again: (cl-delete-duplicates begin ',cl-keys nil)))) - ((and (= 4 (length form)) - (eq :test (third form)) - (or (equal '(quote equal) (fourth form)) - (equal '(function equal) (fourth form)))) - `(let* ((begin ,cl-seq) - (cl-seq begin)) - (if ,listp-check - (progn - (while cl-seq - (setq cl-seq (setcdr cl-seq (delete (car cl-seq) - (cdr cl-seq))))) - begin) - ;; Call cl-delete-duplicates explicitly, to avoid the form - ;; getting compiler-macroexpanded again: - (cl-delete-duplicates begin ',cl-keys nil)))) - (t - form)))) + (t form)))) ;; XEmacs; it's perfectly reasonable, and often much clearer to those ;; reading the code, to call regexp-quote on a constant string, which is