Mercurial > hg > xemacs-beta
comparison lisp/cl-macs.el @ 4794:8484c6c76837
Merge.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 31 Dec 2009 15:47:03 +0000 |
| parents | 8b50bee3c88c 95b04754ea8c |
| children | 6ee5e50a8772 |
comparison
equal
deleted
inserted
replaced
| 4793:8b50bee3c88c | 4794:8484c6c76837 |
|---|---|
| 3348 (define-compiler-macro regexp-quote (&whole form string) | 3348 (define-compiler-macro regexp-quote (&whole form string) |
| 3349 (if (stringp string) | 3349 (if (stringp string) |
| 3350 (regexp-quote string) | 3350 (regexp-quote string) |
| 3351 form)) | 3351 form)) |
| 3352 | 3352 |
| 3353 (define-compiler-macro equalp (&whole form x y) | |
| 3354 "Expand calls to `equalp' where X or Y is a constant expression. | |
| 3355 | |
| 3356 Much of the processing that `equalp' does is dependent on the types of both | |
| 3357 of its arguments, and with type information for one of them, we can | |
| 3358 eliminate much of the body of the function at compile time. | |
| 3359 | |
| 3360 Where both X and Y are constant expressions, `equalp' is evaluated at | |
| 3361 compile time by byte-optimize.el--this compiler macro passes FORM through to | |
| 3362 the byte optimizer in those cases." | |
| 3363 ;; Cases where both arguments are constant are handled in | |
| 3364 ;; byte-optimize.el, we only need to handle those cases where one is | |
| 3365 ;; constant here. | |
| 3366 (let* ((equalp-sym (eval-when-compile (gensym))) | |
| 3367 (let-form '(progn)) | |
| 3368 (check-bit-vector t) | |
| 3369 (check-string t) | |
| 3370 (original-y y) | |
| 3371 equalp-temp checked) | |
| 3372 (macrolet | |
| 3373 ((unordered-check (check) | |
| 3374 `(prog1 | |
| 3375 (setq checked | |
| 3376 (or ,check | |
| 3377 (prog1 ,(sublis '((x . y) (y . x)) check :test #'eq) | |
| 3378 (setq equalp-temp x x y y equalp-temp)))) | |
| 3379 (when checked | |
| 3380 (unless (symbolp y) | |
| 3381 (setq let-form `(let ((,equalp-sym ,y))) y equalp-sym)))))) | |
| 3382 ;; In the bodies of the below clauses, x is always a constant expression | |
| 3383 ;; of the type we're interested in, and y is always a symbol that refers | |
| 3384 ;; to the result non-constant side of the comparison. | |
| 3385 (cond ((unordered-check (and (arrayp x) (not (cl-const-expr-p y)))) | |
| 3386 ;; Strings and other arrays. A vector containing the same | |
| 3387 ;; character elements as a given string is equalp to that string; | |
| 3388 ;; a bit-vector can only be equalp to a string if both are | |
| 3389 ;; zero-length. | |
| 3390 (cond | |
| 3391 ((member x '("" #* [])) | |
| 3392 ;; No need to protect against multiple evaluation here: | |
| 3393 `(and (member ,original-y '("" #* [])) t)) | |
| 3394 ((stringp x) | |
| 3395 `(,@let-form | |
| 3396 (if (stringp ,y) | |
| 3397 (eq t (compare-strings ,x nil nil | |
| 3398 ,y nil nil t)) | |
| 3399 (if (vectorp ,y) | |
| 3400 (cl-string-vector-equalp ,x ,y))))) | |
| 3401 ((bit-vector-p x) | |
| 3402 `(,@let-form | |
| 3403 (if (bit-vector-p ,y) | |
| 3404 ;; No need to call equalp on each element here: | |
| 3405 (equal ,x ,y) | |
| 3406 (if (vectorp ,y) | |
| 3407 (cl-bit-vector-vector-equalp ,x ,y))))) | |
| 3408 (t | |
| 3409 (loop | |
| 3410 for elt across x | |
| 3411 ;; We may not need to check the other argument if it's a | |
| 3412 ;; string or bit vector, depending on the contents of x: | |
| 3413 always (progn | |
| 3414 (unless (characterp elt) (setq check-string nil)) | |
| 3415 (unless (and (numberp elt) (or (= elt 0) (= elt 1))) | |
| 3416 (setq check-bit-vector nil)) | |
| 3417 (or check-string check-bit-vector))) | |
| 3418 `(,@let-form | |
| 3419 (cond | |
| 3420 ,@(if check-string | |
| 3421 `(((stringp ,y) | |
| 3422 (cl-string-vector-equalp ,y ,x)))) | |
| 3423 ,@(if check-bit-vector | |
| 3424 `(((bit-vector-p ,y) | |
| 3425 (cl-bit-vector-vector-equalp ,y ,x)))) | |
| 3426 ((vectorp ,y) | |
| 3427 (cl-vector-array-equalp ,x ,y))))))) | |
| 3428 ((unordered-check (and (characterp x) (not (cl-const-expr-p y)))) | |
| 3429 `(,@let-form | |
| 3430 (or (eq ,x ,y) | |
| 3431 ;; eq has a bytecode, char-equal doesn't. | |
| 3432 (and (characterp ,y) | |
| 3433 (eq (downcase ,x) (downcase ,y)))))) | |
| 3434 ((unordered-check (and (numberp x) (not (cl-const-expr-p y)))) | |
| 3435 `(,@let-form | |
| 3436 (and (numberp ,y) | |
| 3437 (= ,x ,y)))) | |
| 3438 ((unordered-check (and (hash-table-p x) (not (cl-const-expr-p y)))) | |
| 3439 ;; Hash tables; follow the CL spec. | |
| 3440 `(,@let-form | |
| 3441 (and (hash-table-p ,y) | |
| 3442 (eq ',(hash-table-test x) (hash-table-test ,y)) | |
| 3443 (= ,(hash-table-count x) (hash-table-count ,y)) | |
| 3444 (cl-hash-table-contents-equalp ,x ,y)))) | |
| 3445 ((unordered-check | |
| 3446 ;; Symbols; eq. | |
| 3447 (and (not (cl-const-expr-p y)) | |
| 3448 (or (memq x '(nil t)) | |
| 3449 (and (eq (car-safe x) 'quote) (symbolp (second x)))))) | |
| 3450 (cons 'eq (cdr form))) | |
| 3451 ((unordered-check | |
| 3452 ;; Compare conses at runtime, there's no real upside to | |
| 3453 ;; unrolling the function -> they fall through to the next | |
| 3454 ;; clause in this function. | |
| 3455 (and (cl-const-expr-p x) (not (consp x)) | |
| 3456 (not (cl-const-expr-p y)))) | |
| 3457 ;; All other types; use equal. | |
| 3458 (cons 'equal (cdr form))) | |
| 3459 ;; Neither side is a constant expression, do all our evaluation at | |
| 3460 ;; runtime (or both are, and equalp will be called from | |
| 3461 ;; byte-optimize.el). | |
| 3462 (t form))))) | |
| 3463 | |
| 3353 (mapc | 3464 (mapc |
| 3354 #'(lambda (y) | 3465 #'(lambda (y) |
| 3355 (put (car y) 'side-effect-free t) | 3466 (put (car y) 'side-effect-free t) |
| 3356 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) | 3467 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) |
| 3357 (put (car y) 'cl-compiler-macro | 3468 (put (car y) 'cl-compiler-macro |