carbon2-commit: #'delete-duplicates: don't attempt to compiler macroexpand with bad arguments

changeset: 5375:8aa511adfad6 user: Aidan Kehoe <kehoea(a)parhasard.net&gt; date: Wed Dec 29 23:56:57 2010 +0000 files: lisp/ChangeLog lisp/cl-macs.el description: #'delete-duplicates: don't attempt to compiler macroexpand with bad arguments 2010-12-29 Aidan Kehoe <kehoea(a)parhasard.net&gt; * cl-macs.el (delete-duplicates): If the form has an incorrect number of arguments, don't attempt a compiler macroexpansion. diff -r 9ac28212c75a -r 8aa511adfad6 lisp/ChangeLog --- a/lisp/ChangeLog Wed Dec 29 23:53:48 2010 +0000 +++ b/lisp/ChangeLog Wed Dec 29 23:56:57 2010 +0000 ＠＠ -1,3 +1,9 ＠＠ +2010-12-29 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * cl-macs.el (delete-duplicates): + If the form has an incorrect number of arguments, don't attempt a + compiler macroexpansion. + 2010-12-29 Aidan Kehoe <kehoea(a)parhasard.net&gt; * cl-macs.el (cl-safe-expr-p): diff -r 9ac28212c75a -r 8aa511adfad6 lisp/cl-macs.el --- a/lisp/cl-macs.el Wed Dec 29 23:53:48 2010 +0000 +++ b/lisp/cl-macs.el Wed Dec 29 23:56:57 2010 +0000 ＠＠ -3487,56 +3487,60 ＠＠ ;; 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) - (if (not (or (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)) - (and (listp cl-seq) (equal (butlast cl-seq) '(the list))))) - form - (cond - ((or (plists-equal cl-keys '(:test 'eq) t) - (plists-equal cl-keys '(:test #'eq) t)) - `(let* ((begin ,cl-seq) - cl-seq) - (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)) - ((or (plists-equal cl-keys '(:test 'eq :from-end t) t) - (plists-equal cl-keys '(:test #'eq :from-end t) t)) - `(let* ((begin ,cl-seq) - (cl-seq begin)) - (while cl-seq - (setq cl-seq (setcdr cl-seq - (delq (car cl-seq) (cdr cl-seq))))) - begin)) - ((or (plists-equal cl-keys '(:test 'equal) t) - (plists-equal cl-keys '(:test #'equal) t)) - `(let* ((begin ,cl-seq) - cl-seq) - (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)) - ((or (plists-equal cl-keys '(:test 'equal :from-end t) t) - (plists-equal cl-keys '(:test #'equal :from-end t) t)) - `(let* ((begin ,cl-seq) - (cl-seq begin)) - (while cl-seq - (setq cl-seq (setcdr cl-seq (delete (car cl-seq) - (cdr cl-seq))))) - begin)) - (t form)))) +(define-compiler-macro delete-duplicates (&whole form &rest cl-keys) + (let ((cl-seq (if cl-keys (pop cl-keys)))) + (if (or + (not (or (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)) + (and (listp cl-seq) (equal (butlast cl-seq) '(the list))))) + ;; Wrong number of arguments. + (not (cdr form))) + form + (cond + ((or (plists-equal cl-keys '(:test 'eq) t) + (plists-equal cl-keys '(:test #'eq) t)) + `(let* ((begin ,cl-seq) + cl-seq) + (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)) + ((or (plists-equal cl-keys '(:test 'eq :from-end t) t) + (plists-equal cl-keys '(:test #'eq :from-end t) t)) + `(let* ((begin ,cl-seq) + (cl-seq begin)) + (while cl-seq + (setq cl-seq (setcdr cl-seq + (delq (car cl-seq) (cdr cl-seq))))) + begin)) + ((or (plists-equal cl-keys '(:test 'equal) t) + (plists-equal cl-keys '(:test #'equal) t)) + `(let* ((begin ,cl-seq) + cl-seq) + (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)) + ((or (plists-equal cl-keys '(:test 'equal :from-end t) t) + (plists-equal cl-keys '(:test #'equal :from-end t) t)) + `(let* ((begin ,cl-seq) + (cl-seq begin)) + (while cl-seq + (setq cl-seq (setcdr cl-seq (delete (car cl-seq) + (cdr cl-seq))))) + begin)) + (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 _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches