carbon2-commit: Add compiler macros and compilation sanity-checks for functions with keywords.

changeset: 5350:bbff29a01820 user: Aidan Kehoe <kehoea(a)parhasard.net&gt; date: Mon Oct 25 13:04:04 2010 +0100 files: lisp/ChangeLog lisp/byte-optimize.el lisp/bytecomp.el lisp/cl-macs.el lisp/cl.el description: Add compiler macros and compilation sanity-checks for functions with keywords. 2010-10-25 Aidan Kehoe <kehoea(a)parhasard.net&gt; Add compiler macros and compilation sanity-checking for various functions that take keywords. * byte-optimize.el (side-effect-free-fns): #'symbol-value is side-effect free and not error free. * bytecomp.el (byte-compile-normal-call): Check keyword argument lists for sanity; store information about the positions where keyword arguments start using the new byte-compile-keyword-start property. * cl-macs.el (cl-const-expr-val): Take a new optional argument, cl-not-constant, defaulting to nil, in this function; return it if the expression is not constant. (cl-non-fixnum-number-p): Make this into a separate function, we want to pass it to #'every. (eql): Use it. (define-star-compiler-macros): Use the same code to generate the member*, assoc* and rassoc* compiler macros; special-case some code in #'add-to-list in subr.el. (remove, remq): Add compiler macros for these two functions, in preparation for #'remove being in C. (define-foo-if-compiler-macros): Transform (remove-if-not ...) calls to (remove ... :if-not) at compile time, which will be a real win once the latter is in C. (define-substitute-if-compiler-macros) (define-subst-if-compiler-macros): Similarly for these functions. (delete-duplicates): Change this compiler macro to use #'plists-equal; if we don't have information about the type of SEQUENCE at compile time, don't bother attempting to inline the call, the function will be in C soon enough. (equalp): Remove an old commented-out compiler macro for this, if we want to see it it's in version control. (subst-char-in-string): Transform this to a call to nsubstitute or nsubstitute, if that is appropriate. * cl.el (ldiff): Don't call setf here, this makes for a load-time dependency problem in cl-macs.el diff -r 63f247c5da0a -r bbff29a01820 lisp/ChangeLog --- a/lisp/ChangeLog Mon Oct 18 23:43:03 2010 +0900 +++ b/lisp/ChangeLog Mon Oct 25 13:04:04 2010 +0100 ＠＠ -1,3 +1,41 ＠＠ +2010-10-25 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + Add compiler macros and compilation sanity-checking for various + functions that take keywords. + + * byte-optimize.el (side-effect-free-fns): #'symbol-value is + side-effect free and not error free. + * bytecomp.el (byte-compile-normal-call): Check keyword argument + lists for sanity; store information about the positions where + keyword arguments start using the new byte-compile-keyword-start + property. + * cl-macs.el (cl-const-expr-val): Take a new optional argument, + cl-not-constant, defaulting to nil, in this function; return it if + the expression is not constant. + (cl-non-fixnum-number-p): Make this into a separate function, we + want to pass it to #'every. + (eql): Use it. + (define-star-compiler-macros): Use the same code to generate the + member*, assoc* and rassoc* compiler macros; special-case some + code in #'add-to-list in subr.el. + (remove, remq): Add compiler macros for these two functions, in + preparation for #'remove being in C. + (define-foo-if-compiler-macros): Transform (remove-if-not ...) calls to + (remove ... :if-not) at compile time, which will be a real win + once the latter is in C. + (define-substitute-if-compiler-macros) + (define-subst-if-compiler-macros): Similarly for these functions. + (delete-duplicates): Change this compiler macro to use + #'plists-equal; if we don't have information about the type of + SEQUENCE at compile time, don't bother attempting to inline the + call, the function will be in C soon enough. + (equalp): Remove an old commented-out compiler macro for this, if + we want to see it it's in version control. + (subst-char-in-string): Transform this to a call to nsubstitute or + nsubstitute, if that is appropriate. + * cl.el (ldiff): Don't call setf here, this makes for a load-time + dependency problem in cl-macs.el + 2010-06-14 Stephen J. Turnbull <stephen(a)xemacs.org&gt; * term/vt100.el: diff -r 63f247c5da0a -r bbff29a01820 lisp/byte-optimize.el --- a/lisp/byte-optimize.el Mon Oct 18 23:43:03 2010 +0900 +++ b/lisp/byte-optimize.el Mon Oct 25 13:04:04 2010 +0100 ＠＠ -1247,7 +1247,8 ＠＠ parse-colon-path plist-get previous-window radians-to-degrees rassq regexp-quote reverse round sin sqrt string< string= string-equal string-lessp string-to-char - string-to-int string-to-number substring symbol-plist + string-to-int string-to-number substring symbol-plist symbol-value + symbol-name symbol-function symbol tan upcase user-variable-p vconcat ;; XEmacs change: window-edges -> window-pixel-edges window-buffer window-dedicated-p window-pixel-edges window-height diff -r 63f247c5da0a -r bbff29a01820 lisp/bytecomp.el --- a/lisp/bytecomp.el Mon Oct 18 23:43:03 2010 +0900 +++ b/lisp/bytecomp.el Mon Oct 25 13:04:04 2010 +0100 ＠＠ -2838,7 +2838,83 ＠＠ (when for-effect (byte-compile-discard))) +;; Generate the list of functions with keyword arguments like so: +;; +;; (delete-duplicates +;; (sort* +;; (loop +;; for symbol being each symbol in obarray +;; with arglist = nil +;; if (and (fboundp symbol) +;; (ignore-errors (setq symbol (indirect-function symbol))) +;; (cond +;; ((and (subrp symbol) (setq symbol (intern (subr-name symbol))))) +;; ((and (compiled-function-p symbol) +;; (setq symbol (compiled-function-annotation symbol))))) +;; (setq arglist (function-arglist symbol)) +;; (setq arglist (ignore-errors (read-from-string arglist))) +;; (setq arglist (car arglist)) +;; (setq arglist (position '&key arglist))) +;; collect (cons symbol arglist)) +;; #'string-lessp +;;:key #'car) :test #'eq :key #'car) +;; +;; That won't include those that take advantage of cl-seq.el's +;; cl-parsing-keywords macro, but the below list does. + +(map nil + (function* + (lambda ((function . nargs)) + ;; Document that the car of OBJECT, a symbol, describes a function + ;; taking keyword arguments from the argument index described by + ;; the cdr of OBJECT. + (put function 'byte-compile-keyword-start nargs))) + '((adjoin . 3) (assoc* . 3) (assoc-if . 3) (assoc-if-not . 3) + (count . 3) (count-if . 3) (count-if-not . 3) (define-behavior . 3) + (define-behavior-group . 2) (delete* . 3) (delete-duplicates . 2) + (delete-if . 3) (delete-if-not . 3) (fill . 3) (find . 3) (find-if . 3) + (find-if-not . 3) (internal-make-translation-table . 1) + (make-Print-context . 1) (make-hash-table . 1) (make-saved-window . 1) + (make-window-configuration . 1) (member* . 3) + (member-if . 3) (member-if-not . 3) (merge . 5) (nsublis . 3) + (nsubst . 4) (nsubst-if . 4) (nsubst-if-not . 4) (nsubstitute . 4) + (nsubstitute-if . 4) (nsubstitute-if-not . 4) (override-behavior . 2) + (position . 3) (position-if . 3) (position-if-not . 3) (rassoc* . 3) + (rassoc-if . 3) (rassoc-if-not . 3) (reduce . 3) (remove* . 3) + (remove-duplicates . 2) (remove-if . 3) (remove-if-not . 3) + (replace . 3) (sort* . 3) (stable-sort . 3) (sublis . 3) + (subsetp . 3) (subst . 4) (subst-if . 4) (subst-if-not . 4) + (substitute . 4) (substitute-if . 4) (substitute-if-not . 4) + (tree-equal . 3))) + (defun byte-compile-normal-call (form) + (and (get (car form) 'byte-compile-keyword-start) + (let ((plist (nthcdr (get (car form) 'byte-compile-keyword-start) + form))) + (symbol-macrolet + ((not-present '#:not-present)) + (if (not (valid-plist-p plist)) + (byte-compile-warn + "#'%s: ill-formed keyword argument list: %S" (car form) plist) + (and + (memq 'callargs byte-compile-warnings) + (map nil + (function* + (lambda ((function . nargs)) + (and (setq function (plist-get plist function + not-present)) + (not (eq function not-present)) + (byte-compile-constp function) + (byte-compile-callargs-warn + (cons (eval function) + (member* + nargs + ;; Dummy arguments. There's no need for + ;; it to be longer than even 2, now, but + ;; very little harm in it. + '(9 8 7 6 5 4 3 2 1))))))) + '((:key . 1) (:test . 2) (:test-not . 2) + (:if . 1) (:if-not . 1)))))))) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) (byte-compile-push-constant (car form)) diff -r 63f247c5da0a -r bbff29a01820 lisp/cl-macs.el --- a/lisp/cl-macs.el Mon Oct 18 23:43:03 2010 +0900 +++ b/lisp/cl-macs.el Mon Oct 25 13:04:04 2010 +0100 ＠＠ -135,8 +135,11 ＠＠ (setq xs (cdr xs))) (not xs)) -(defun cl-const-expr-val (x) - (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x))) +(defun cl-const-expr-val (x &optional cl-not-constant) + (let ((cl-const-expr-p (cl-const-expr-p x))) + (cond ((eq cl-const-expr-p t) (if (consp x) (nth 1 x) x)) + ((eq cl-const-expr-p 'func) (nth 1 x)) + (cl-not-constant)))) (defun cl-expr-access-order (x v) (if (cl-const-expr-p x) v ＠＠ -3264,16 +3267,19 ＠＠ ;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, ;;; mainly to make sure these macros will be present. +(defun cl-non-fixnum-number-p (object) + (and (numberp object) (not (fixnump object)))) + (put 'eql 'byte-compile nil) (define-compiler-macro eql (&whole form a b) (cond ((eq (cl-const-expr-p a) t) (let ((val (cl-const-expr-val a))) - (if (and (numberp val) (not (fixnump val))) + (if (cl-non-fixnum-number-p val) (list 'equal a b) (list 'eq a b)))) ((eq (cl-const-expr-p b) t) (let ((val (cl-const-expr-val b))) - (if (and (numberp val) (not (fixnump val))) + (if (cl-non-fixnum-number-p val) (list 'equal a b) (list 'eq a b)))) ((cl-simple-expr-p a 5) ＠＠ -3287,50 +3293,177 ＠＠ (list 'eq a b))) (t form))) -(define-compiler-macro member* (&whole form a list &rest keys) - (let ((test (and (= (length keys) 2) (eq (car keys) :test) - (cl-const-expr-val (nth 1 keys)))) - a-val) - (cond ((eq test 'eq) (list 'memq a list)) - ((eq test 'equal) (list 'member a list)) - ((or (null keys) (eq test 'eql)) - (if (eq (cl-const-expr-p a) t) - (list (if (and (numberp (setq a-val (cl-const-expr-val a))) - (not (fixnump a-val))) - 'member - 'memq) - a list) - (if (eq (cl-const-expr-p list) t) - (let ((p (cl-const-expr-val list)) (mb nil) (mq nil)) - (if (not (cdr p)) - (and p (list 'eql a (list 'quote (car p)))) - (while p - (if (and (numberp (car p)) (not (fixnump (car p)))) - (setq mb t) - (or (fixnump (car p)) (symbolp (car p)) (setq mq t))) - (setq p (cdr p))) - (if (not mb) (list 'memq a list) - (if (not mq) (list 'member a list) form)))) - form))) - (t form)))) - -(define-compiler-macro assoc* (&whole form a list &rest keys) - (let ((test (and (= (length keys) 2) (eq (car keys) :test) - (cl-const-expr-val (nth 1 keys)))) - a-val) - (cond ((eq test 'eq) (list 'assq a list)) - ((eq test 'equal) (list 'assoc a list)) - ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql))) - (if (and (numberp (setq a-val (cl-const-expr-val a))) - (not (fixnump a-val))) - (list 'assoc a list) (list 'assq a list))) - (t form)))) +(macrolet + ((define-star-compiler-macros (&rest macros) + "For `member*', `assoc*' and `rassoc*' with constant ITEM or +:test arguments, use the versions with explicit tests if that makes sense." + (list* + 'progn + (mapcar + (function* + (lambda ((star-function eq-function equal-function)) + `(define-compiler-macro ,star-function (&whole form item list + &rest keys) + (condition-case nil + (symbol-macrolet ((not-constant '#:not-constant)) + (let* ((test-expr (plist-get keys :test ''eql)) + (test (cl-const-expr-val test-expr not-constant)) + (item-val (cl-const-expr-val item not-constant)) + (list-val (cl-const-expr-val list not-constant))) + (if (and keys + (not (and (eq :test (car keys)) + (eql 2 (length keys))))) + form + (cond ((eq test 'eq) `(,',eq-function ,item ,list)) + ((eq test 'equal) + `(,',equal-function ,item ,list)) + ((and (eq test 'eql) + (not (eq not-constant item-val))) + (if (cl-non-fixnum-number-p item-val) + `(,',equal-function ,item ,list) + `(,',eq-function ,item ,list))) + ((and (eq test 'eql) (not (eq not-constant + list-val))) + (if (some 'cl-non-fixnum-number-p list-val) + `(,',equal-function ,item ,list) + ;; This compiler macro used to limit calls + ;; to ,,eq-function to lists where all + ;; elements were either fixnums or + ;; symbols. There's no + ;; reason to do this. + `(,',eq-function ,item ,list))) + ;; This is a hilariously specific case; see + ;; add-to-list in subr.el. + ((and (eq test not-constant) + (eq 'or (car-safe test-expr)) + (eql 3 (length test-expr)) + (every #'cl-safe-expr-p (cdr form)) + `(if ,(second test-expr) + (,',star-function ,item ,list :test + ,(second test-expr)) + (,',star-function + ,item ,list :test ,(third test-expr))))) + (t form))))) + ;; No need to warn about a malformed property list, + ;; #'byte-compile-normal-call will do that for us. + (malformed-property-list form))))) + macros)))) + (define-star-compiler-macros + (member* memq member) + (assoc* assq assoc) + (rassoc* rassq rassoc))) (define-compiler-macro adjoin (&whole form a list &rest keys) (if (and (cl-simple-expr-p a) (cl-simple-expr-p list) (not (memq :key keys))) (list 'if (list* 'member* a list keys) list (list 'cons a list)) form)) + +(define-compiler-macro remove (item sequence) + `(remove* ,item ,sequence :test #'equal)) + +(define-compiler-macro remq (item sequence) + `(remove* ,item ,sequence :test #'eq)) + +(macrolet + ((define-foo-if-compiler-macros (&rest alist) + "Avoid the funcall, variable binding and keyword parsing overhead +for the FOO-IF and FOO-IF-NOT functions, transforming to forms using the +non-standard:if and :if-not keywords at compile time." + (cons + 'progn + (mapcar + (function* + (lambda ((function-if . function)) + (let ((keyword (if (equal (substring (symbol-name function-if) -3) + "not") + :if-not + :if))) + `(define-compiler-macro ,function-if (&whole form &rest args) + (if (and (nthcdr 2 form) + (or (consp (cl-const-expr-val (second form))) + (cl-safe-expr-p (second form)))) + ;; It doesn't matter what the second argument is, it's + ;; ignored by FUNCTION. We know that the symbol + ;; FUNCTION is in the constants vector, so use it. + `(,',function ',',function ,(third form) ,,keyword + ,(second form) ,＠(nthcdr 3 form)) + form))))) + alist)))) + (define-foo-if-compiler-macros + (remove-if . remove*) + (remove-if-not . remove*) + (delete-if . delete*) + (delete-if-not . delete*) + (find-if . find) + (find-if-not . find) + (position-if . position) + (position-if-not . position) + (count-if . count) + (count-if-not . count) + (member-if . member*) + (member-if-not . member*) + (assoc-if . assoc*) + (assoc-if-not . assoc*) + (rassoc-if . rassoc*) + (rassoc-if-not . rassoc*))) + +(macrolet + ((define-substitute-if-compiler-macros (&rest alist) + "Like the above, but for `substitute-if' and friends." + (cons + 'progn + (mapcar + (function* + (lambda ((function-if . function)) + (let ((keyword (if (equal (substring (symbol-name function-if) -3) + "not") + :if-not + :if))) + `(define-compiler-macro ,function-if (&whole form &rest args) + (if (and (nthcdr 3 form) + (or (consp (cl-const-expr-val (third form))) + (cl-safe-expr-p (third form)))) + `(,',function ,(second form) ',',function ,(fourth form) + ,,keyword ,(third form) ,＠(nthcdr 4 form)) + form))))) + alist)))) + (define-substitute-if-compiler-macros + (substitute-if . substitute) + (substitute-if-not . substitute) + (nsubstitute-if . nsubstitute) + (nsubstitute-if-not . nsubstitute))) + +(macrolet + ((define-subst-if-compiler-macros (&rest alist) + "Like the above, but for `subst-if' and friends." + (cons + 'progn + (mapcar + (function* + (lambda ((function-if . function)) + (let ((keyword (if (equal (substring (symbol-name function-if) -3) + "not") + :if-not + :if))) + `(define-compiler-macro ,function-if (&whole form &rest args) + (if (and (nthcdr 3 form) + (or (consp (cl-const-expr-val (third form))) + (cl-safe-expr-p (third form)))) + `(,',function ,(if (cl-const-expr-p (second form)) + `'((nil . ,(cl-const-expr-val + (second form)))) + `(list (cons ',',function + ,(second form)))) + ,(fourth form) ,,keyword ,(third form) + ,＠(nthcdr 4 form)) + form))))) + alist)))) + (define-subst-if-compiler-macros + (subst-if . sublis) + (subst-if-not . sublis) + (nsubst-if . nsublis) + (nsubst-if-not . nsublis))) (define-compiler-macro list* (arg &rest others) (let* ((args (reverse (cons arg others))) ＠＠ -3362,106 +3495,55 ＠＠ ;; 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 - (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 (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)))) + (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)))) ;; XEmacs; it's perfectly reasonable, and often much clearer to those ;; reading the code, to call regexp-quote on a constant string, which is ＠＠ -3559,117 +3641,6 ＠＠ ;; runtime (or both are, and equalp will be called from ;; byte-optimize.el). (t form))))) - -;;(define-compiler-macro equalp (&whole form x y) -;; "Expand calls to `equalp' where X or Y is a constant expression. -;; -;;Much of the processing that `equalp' does is dependent on the types of both -;;of its arguments, and with type information for one of them, we can -;;eliminate much of the body of the function at compile time. -;; -;;Where both X and Y are constant expressions, `equalp' is evaluated at -;;compile time by byte-optimize.el--this compiler macro passes FORM through to -;;the byte optimizer in those cases." -;; ;; Cases where both arguments are constant are handled in -;; ;; byte-optimize.el, we only need to handle those cases where one is -;; ;; constant here. -;; (let* ((equalp-sym (eval-when-compile (gensym))) -;; (let-form '(progn)) -;; (check-bit-vector t) -;; (check-string t) -;; (original-y y) -;; equalp-temp checked) -;; (macrolet -;; ((unordered-check (check) -;; `(prog1 -;; (setq checked -;; (or ,check -;; (prog1 ,(sublis '((x . y) (y . x)) check :test #'eq) -;; (setq equalp-temp x x y y equalp-temp)))) -;; (when checked -;; (unless (symbolp y) -;; (setq let-form `(let ((,equalp-sym ,y))) y equalp-sym)))))) -;; ;; In the bodies of the below clauses, x is always a constant expression -;; ;; of the type we're interested in, and y is always a symbol that refers -;; ;; to the result non-constant side of the comparison. -;; (cond ((unordered-check (and (arrayp x) (not (cl-const-expr-p y)))) -;; ;; Strings and other arrays. A vector containing the same -;; ;; character elements as a given string is equalp to that string; -;; ;; a bit-vector can only be equalp to a string if both are -;; ;; zero-length. -;; (cond -;; ((member x '("" #* [])) -;; ;; No need to protect against multiple evaluation here: -;; `(and (member ,original-y '("" #* [])) t)) -;; ((stringp x) -;; `(,＠let-form -;; (if (stringp ,y) -;; (eq t (compare-strings ,x nil nil -;; ,y nil nil t)) -;; (if (vectorp ,y) -;; (cl-string-vector-equalp ,x ,y))))) -;; ((bit-vector-p x) -;; `(,＠let-form -;; (if (bit-vector-p ,y) -;; ;; No need to call equalp on each element here: -;; (equal ,x ,y) -;; (if (vectorp ,y) -;; (cl-bit-vector-vector-equalp ,x ,y))))) -;; (t -;; (loop -;; for elt across x -;; ;; We may not need to check the other argument if it's a -;; ;; string or bit vector, depending on the contents of x: -;; always (progn -;; (unless (characterp elt) (setq check-string nil)) -;; (unless (and (numberp elt) (or (= elt 0) (= elt 1))) -;; (setq check-bit-vector nil)) -;; (or check-string check-bit-vector))) -;; `(,＠let-form -;; (cond -;; ,＠(if check-string -;; `(((stringp ,y) -;; (cl-string-vector-equalp ,y ,x)))) -;; ,＠(if check-bit-vector -;; `(((bit-vector-p ,y) -;; (cl-bit-vector-vector-equalp ,y ,x)))) -;; ((vectorp ,y) -;; (cl-vector-array-equalp ,x ,y))))))) -;; ((unordered-check (and (characterp x) (not (cl-const-expr-p y)))) -;; `(,＠let-form -;; (or (eq ,x ,y) -;; ;; eq has a bytecode, char-equal doesn't. -;; (and (characterp ,y) -;; (eq (downcase ,x) (downcase ,y)))))) -;; ((unordered-check (and (numberp x) (not (cl-const-expr-p y)))) -;; `(,＠let-form -;; (and (numberp ,y) -;; (= ,x ,y)))) -;; ((unordered-check (and (hash-table-p x) (not (cl-const-expr-p y)))) -;; ;; Hash tables; follow the CL spec. -;; `(,＠let-form -;; (and (hash-table-p ,y) -;; (eq ',(hash-table-test x) (hash-table-test ,y)) -;; (= ,(hash-table-count x) (hash-table-count ,y)) -;; (cl-hash-table-contents-equalp ,x ,y)))) -;; ((unordered-check -;; ;; Symbols; eq. -;; (and (not (cl-const-expr-p y)) -;; (or (memq x '(nil t)) -;; (and (eq (car-safe x) 'quote) (symbolp (second x)))))) -;; (cons 'eq (cdr form))) -;; ((unordered-check -;; ;; Compare conses at runtime, there's no real upside to -;; ;; unrolling the function -> they fall through to the next -;; ;; clause in this function. -;; (and (cl-const-expr-p x) (not (consp x)) -;; (not (cl-const-expr-p y)))) -;; ;; All other types; use equal. -;; (cons 'equal (cdr form))) -;; ;; Neither side is a constant expression, do all our evaluation at -;; ;; runtime (or both are, and equalp will be called from -;; ;; byte-optimize.el). -;; (t form))))) (define-compiler-macro notany (&whole form &rest cl-rest) `(not (some ,＠(cdr form)))) ＠＠ -3773,6 +3744,13 ＠＠ (string (cons 'concat (cddr form)))) form)) +(define-compiler-macro subst-char-in-string (&whole form fromchar tochar + string &optional inplace) + (if (every #'cl-safe-expr-p (cdr form)) + `(funcall (if ,inplace #'nsubstitute #'substitute) ,tochar ,fromchar + (the string ,string) :test #'eq) + form)) + (map nil #'(lambda (function) ;; There are byte codes for the two-argument versions of these diff -r 63f247c5da0a -r bbff29a01820 lisp/cl.el --- a/lisp/cl.el Mon Oct 18 23:43:03 2010 +0900 +++ b/lisp/cl.el Mon Oct 25 13:04:04 2010 +0100 ＠＠ -542,8 +542,8 ＠＠ (prog1 (setq result (list (car list))) (while (and (setq list (cdr-safe list)) (not (eql list sublist))) - (setf (cdr result) (if (consp list) (list (car list)) list) - result (cdr result) + (setcdr result (if (consp list) (list (car list)) list)) + (setq result (cdr result) evenp (not evenp)) (if evenp (setq before (cdr before))) (if (eq before list) (error 'circular-list list))))))) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches