Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 4906:6ef8256a020a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
implement equalp in C, fix case-folding, add equal() method for keymaps -------------------- ChangeLog entries follow: -------------------- lisp/ChangeLog addition: 2010-02-01 Ben Wing <ben@xemacs.org> * cl-extra.el: * cl-extra.el (cl-string-vector-equalp): Removed. * cl-extra.el (cl-bit-vector-vector-equalp): Removed. * cl-extra.el (cl-vector-array-equalp): Removed. * cl-extra.el (cl-hash-table-contents-equalp): Removed. * cl-extra.el (equalp): Removed. * cl-extra.el (cl-mapcar-many): Comment out the whole `equalp' implementation for the moment; remove once we're sure the C implementation works. * cl-macs.el: * cl-macs.el (equalp): Simplify the compiler-macro for `equalp' -- once it's in C, we don't need to try so hard to expand it. src/ChangeLog addition: 2010-02-01 Ben Wing <ben@xemacs.org> * abbrev.c (abbrev_match_mapper): * buffer.h (CANON_TABLE_OF): * buffer.h: * editfns.c (Fchar_equal): * minibuf.c (scmp_1): * text.c (qxestrcasecmp_i18n): * text.c (qxestrncasecmp_i18n): * text.c (qxetextcasecmp): * text.c (qxetextcasecmp_matching): Create new macro CANONCASE that converts to a canonical mapping and use it to do caseless comparisons instead of DOWNCASE. * alloc.c: * alloc.c (cons_equal): * alloc.c (vector_equal): * alloc.c (string_equal): * bytecode.c (compiled_function_equal): * chartab.c (char_table_entry_equal): * chartab.c (char_table_equal): * data.c (weak_list_equal): * data.c (weak_box_equal): * data.c (ephemeron_equal): * device-msw.c (equal_devmode): * elhash.c (hash_table_equal): * events.c (event_equal): * extents.c (properties_equal): * extents.c (extent_equal): * faces.c: * faces.c (face_equal): * faces.c (face_hash): * floatfns.c (float_equal): * fns.c: * fns.c (bit_vector_equal): * fns.c (plists_differ): * fns.c (Fplists_eq): * fns.c (Fplists_equal): * fns.c (Flax_plists_eq): * fns.c (Flax_plists_equal): * fns.c (internal_equal): * fns.c (internal_equalp): * fns.c (internal_equal_0): * fns.c (syms_of_fns): * glyphs.c (image_instance_equal): * glyphs.c (glyph_equal): * glyphs.c (glyph_hash): * gui.c (gui_item_equal): * lisp.h: * lrecord.h (struct lrecord_implementation): * marker.c (marker_equal): * number.c (bignum_equal): * number.c (ratio_equal): * number.c (bigfloat_equal): * objects.c (color_instance_equal): * objects.c (font_instance_equal): * opaque.c (equal_opaque): * opaque.c (equal_opaque_ptr): * rangetab.c (range_table_equal): * specifier.c (specifier_equal): Add a `foldcase' param to the equal() method and use it to implement `equalp' comparisons. Also add to plists_differ(), although we don't currently use it here. Rewrite internal_equalp(). Implement cross-type vector comparisons. Don't implement our own handling of numeric promotion -- just use the `=' primitive. Add internal_equal_0(), which takes a `foldcase' param and calls either internal_equal() or internal_equalp(). * buffer.h: When given a 0 for buffer (which is the norm when functions don't have a specific buffer available), use the current buffer's table, not `standard-case-table'; otherwise the current settings are ignored. * casetab.c: * casetab.c (set_case_table): When handling old-style vectors of 256 in `set-case-table' don't overwrite the existing table! Instead create a new table and populate. * device-msw.c (sync_printer_with_devmode): * lisp.h: * text.c (lisp_strcasecmp_ascii): Rename lisp_strcasecmp to lisp_strcasecmp_ascii and use lisp_strcasecmp_i18n for caseless comparisons in some places. * elhash.c: Delete unused lisp_string_hash and lisp_string_equal(). * events.h: * keymap-buttons.h: * keymap.h: * keymap.c (keymap_lookup_directly): * keymap.c (keymap_store): * keymap.c (FROB): * keymap.c (key_desc_list_to_event): * keymap.c (describe_map_mapper): * keymap.c (INCLUDE_BUTTON_ZERO): New file keymap-buttons.h; use to handle buttons 1-26 in place of duplicating code 26 times. * frame-gtk.c (allocate_gtk_frame_struct): * frame-msw.c (mswindows_init_frame_1): Fix some comments about internal_equal() in redisplay that don't apply any more. * keymap-slots.h: * keymap.c: New file keymap-slots.h. Use it to notate the slots in a keymap structure, similar to frameslots.h or coding-system-slots.h. * keymap.c (MARKED_SLOT): * keymap.c (keymap_equal): * keymap.c (keymap_hash): Implement. tests/ChangeLog addition: 2010-02-01 Ben Wing <ben@xemacs.org> * automated/case-tests.el: * automated/case-tests.el (uni-mappings): * automated/search-tests.el: Delete old pristine-case-table code. Rewrite the Unicode torture test to take into account whether overlapping mappings exist for more than one character, and not doing the upcase/downcase comparisons in such cases. * automated/lisp-tests.el (foo): * automated/lisp-tests.el (string-variable): * automated/lisp-tests.el (featurep): Replace Assert (equal ... with Assert-equal; same for other types of equality. Replace some awkward equivalents of Assert-equalp with Assert-equalp. Add lots of equalp tests. * automated/case-tests.el: * automated/regexp-tests.el: * automated/search-tests.el: Fix up the comments at the top of the files. Move rules about where to put tests into case-tests.el. * automated/test-harness.el: * automated/test-harness.el (test-harness-aborted-summary-template): New. * automated/test-harness.el (test-harness-from-buffer): * automated/test-harness.el (batch-test-emacs): Fix Assert-test-not. Create Assert-not-equal and variants. Delete the doc strings from all these convenience functions to avoid excessive repetition; instead use one copy in a comment.
author Ben Wing <ben@xemacs.org>
date Mon, 01 Feb 2010 01:02:40 -0600
parents 6772ce4d982b
children 6bc1f3f6cf0d
comparison
equal deleted inserted replaced
4903:70089046adef 4906:6ef8256a020a
1 ;;; cl-macs.el --- Common Lisp extensions for XEmacs Lisp (part four) 1 ;;; cl-macs.el --- Common Lisp extensions for XEmacs Lisp (part four)
2 2
3 ;; Copyright (C) 1993, 2003, 2004 Free Software Foundation, Inc. 3 ;; Copyright (C) 1993, 2003, 2004 Free Software Foundation, Inc.
4 ;; Copyright (C) 2002 Ben Wing. 4 ;; Copyright (C) 2002, 2010 Ben Wing.
5 5
6 ;; Author: Dave Gillespie <daveg@synaptics.com> 6 ;; Author: Dave Gillespie <daveg@synaptics.com>
7 ;; Version: 2.02 7 ;; Version: 2.02
8 ;; Keywords: extensions 8 ;; Keywords: extensions
9 9
3355 (define-compiler-macro regexp-quote (&whole form string) 3355 (define-compiler-macro regexp-quote (&whole form string)
3356 (if (stringp string) 3356 (if (stringp string)
3357 (regexp-quote string) 3357 (regexp-quote string)
3358 form)) 3358 form))
3359 3359
3360 ;; NOTE: `equalp' is now a primitive, although as of yet it still doesn't
3361 ;; have a byte-compiler opcode for it. The compiler-macro for `equalp' used
3362 ;; to try and remove as much as possible of the logic of the Lisp `equalp' as
3363 ;; possible whenever one of the arguments is a constant, boiling things down
3364 ;; to a few if-statements and some calls to various no-longer-defined
3365 ;; helper functions. Besides the fact that the helper functions aren't
3366 ;; defined, there's little point in doing any of that expansion, since it will
3367 ;; end up executing in Lisp what would otherwise be done in C by a direct
3368 ;; call to `equalp'. The only exception is when the reduction is quite
3369 ;; simple and is to functions that do have op-codes; that may gain something.
3370 ;; However, if `equalp' becomes an opcode itself, consider removing everything
3371 ;; here except maybe when the call can directly be reduced to `equal' or `eq'.
3372 ;;
3373 ;; --ben
3374
3360 (define-compiler-macro equalp (&whole form x y) 3375 (define-compiler-macro equalp (&whole form x y)
3361 "Expand calls to `equalp' where X or Y is a constant expression. 3376 "Expand calls to `equalp' where X or Y is a constant expression.
3362 3377
3363 Much of the processing that `equalp' does is dependent on the types of both 3378 Much of the processing that `equalp' does is dependent on the types of both
3364 of its arguments, and with type information for one of them, we can 3379 of its arguments, and with type information for one of them, we can
3370 ;; Cases where both arguments are constant are handled in 3385 ;; Cases where both arguments are constant are handled in
3371 ;; byte-optimize.el, we only need to handle those cases where one is 3386 ;; byte-optimize.el, we only need to handle those cases where one is
3372 ;; constant here. 3387 ;; constant here.
3373 (let* ((equalp-sym (eval-when-compile (gensym))) 3388 (let* ((equalp-sym (eval-when-compile (gensym)))
3374 (let-form '(progn)) 3389 (let-form '(progn))
3375 (check-bit-vector t)
3376 (check-string t)
3377 (original-y y) 3390 (original-y y)
3378 equalp-temp checked) 3391 equalp-temp checked)
3379 (macrolet 3392 (macrolet
3380 ((unordered-check (check) 3393 ((unordered-check (check)
3381 `(prog1 3394 `(prog1
3396 ;; zero-length. 3409 ;; zero-length.
3397 (cond 3410 (cond
3398 ((member x '("" #* [])) 3411 ((member x '("" #* []))
3399 ;; No need to protect against multiple evaluation here: 3412 ;; No need to protect against multiple evaluation here:
3400 `(and (member ,original-y '("" #* [])) t)) 3413 `(and (member ,original-y '("" #* [])) t))
3401 ((stringp x) 3414 (t form)))
3402 `(,@let-form
3403 (if (stringp ,y)
3404 (eq t (compare-strings ,x nil nil
3405 ,y nil nil t))
3406 (if (vectorp ,y)
3407 (cl-string-vector-equalp ,x ,y)))))
3408 ((bit-vector-p x)
3409 `(,@let-form
3410 (if (bit-vector-p ,y)
3411 ;; No need to call equalp on each element here:
3412 (equal ,x ,y)
3413 (if (vectorp ,y)
3414 (cl-bit-vector-vector-equalp ,x ,y)))))
3415 (t
3416 (loop
3417 for elt across x
3418 ;; We may not need to check the other argument if it's a
3419 ;; string or bit vector, depending on the contents of x:
3420 always (progn
3421 (unless (characterp elt) (setq check-string nil))
3422 (unless (and (numberp elt) (or (= elt 0) (= elt 1)))
3423 (setq check-bit-vector nil))
3424 (or check-string check-bit-vector)))
3425 `(,@let-form
3426 (cond
3427 ,@(if check-string
3428 `(((stringp ,y)
3429 (cl-string-vector-equalp ,y ,x))))
3430 ,@(if check-bit-vector
3431 `(((bit-vector-p ,y)
3432 (cl-bit-vector-vector-equalp ,y ,x))))
3433 ((vectorp ,y)
3434 (cl-vector-array-equalp ,x ,y)))))))
3435 ((unordered-check (and (characterp x) (not (cl-const-expr-p y)))) 3415 ((unordered-check (and (characterp x) (not (cl-const-expr-p y))))
3436 `(,@let-form 3416 `(,@let-form
3437 (or (eq ,x ,y) 3417 (or (eq ,x ,y)
3438 ;; eq has a bytecode, char-equal doesn't. 3418 ;; eq has a bytecode, char-equal doesn't.
3439 (and (characterp ,y) 3419 (and (characterp ,y)
3440 (eq (downcase ,x) (downcase ,y)))))) 3420 (eq (downcase ,x) (downcase ,y))))))
3441 ((unordered-check (and (numberp x) (not (cl-const-expr-p y)))) 3421 ((unordered-check (and (numberp x) (not (cl-const-expr-p y))))
3442 `(,@let-form 3422 `(,@let-form
3443 (and (numberp ,y) 3423 (and (numberp ,y)
3444 (= ,x ,y)))) 3424 (= ,x ,y))))
3445 ((unordered-check (and (hash-table-p x) (not (cl-const-expr-p y)))) 3425 ((unordered-check (and (hash-table-p x) (not (cl-const-expr-p y))))
3446 ;; Hash tables; follow the CL spec. 3426 form)
3447 `(,@let-form
3448 (and (hash-table-p ,y)
3449 (eq ',(hash-table-test x) (hash-table-test ,y))
3450 (= ,(hash-table-count x) (hash-table-count ,y))
3451 (cl-hash-table-contents-equalp ,x ,y))))
3452 ((unordered-check 3427 ((unordered-check
3453 ;; Symbols; eq. 3428 ;; Symbols; eq.
3454 (and (not (cl-const-expr-p y)) 3429 (and (not (cl-const-expr-p y))
3455 (or (memq x '(nil t)) 3430 (or (memq x '(nil t))
3456 (and (eq (car-safe x) 'quote) (symbolp (second x)))))) 3431 (and (eq (car-safe x) 'quote) (symbolp (second x))))))
3457 (cons 'eq (cdr form))) 3432 (cons 'eq (cdr form)))
3458 ((unordered-check 3433
3459 ;; Compare conses at runtime, there's no real upside to 3434 ;; This clause is wrong -- e.g. when comparing a constant char-table
3460 ;; unrolling the function -> they fall through to the next 3435 ;; against a non-constant expression that evaluates to a char-table,
3461 ;; clause in this function. 3436 ;; or some for range tables or certain other types, `equalp' is
3462 (and (cl-const-expr-p x) (not (consp x)) 3437 ;; not the same as `equal'. We could insert the known list of
3463 (not (cl-const-expr-p y)))) 3438 ;; types with special `equalp' property, but it's fragile and may
3464 ;; All other types; use equal. 3439 ;; not be much of an optimization, esp. since these types don't
3465 (cons 'equal (cdr form))) 3440 ;; occur that often are often big.
3441 ;;((unordered-check
3442 ;; ;; Compare conses at runtime, there's no real upside to
3443 ;; ;; unrolling the function -> they fall through to the next
3444 ;; ;; clause in this function.
3445 ;; (and (cl-const-expr-p x) (not (consp x))
3446 ;; (not (cl-const-expr-p y))))
3447 ;; ;; All other types; use equal.
3448 ;; (cons 'equal (cdr form)))
3449
3466 ;; Neither side is a constant expression, do all our evaluation at 3450 ;; Neither side is a constant expression, do all our evaluation at
3467 ;; runtime (or both are, and equalp will be called from 3451 ;; runtime (or both are, and equalp will be called from
3468 ;; byte-optimize.el). 3452 ;; byte-optimize.el).
3469 (t form))))) 3453 (t form)))))
3454
3455 ;;(define-compiler-macro equalp (&whole form x y)
3456 ;; "Expand calls to `equalp' where X or Y is a constant expression.
3457 ;;
3458 ;;Much of the processing that `equalp' does is dependent on the types of both
3459 ;;of its arguments, and with type information for one of them, we can
3460 ;;eliminate much of the body of the function at compile time.
3461 ;;
3462 ;;Where both X and Y are constant expressions, `equalp' is evaluated at
3463 ;;compile time by byte-optimize.el--this compiler macro passes FORM through to
3464 ;;the byte optimizer in those cases."
3465 ;; ;; Cases where both arguments are constant are handled in
3466 ;; ;; byte-optimize.el, we only need to handle those cases where one is
3467 ;; ;; constant here.
3468 ;; (let* ((equalp-sym (eval-when-compile (gensym)))
3469 ;; (let-form '(progn))
3470 ;; (check-bit-vector t)
3471 ;; (check-string t)
3472 ;; (original-y y)
3473 ;; equalp-temp checked)
3474 ;; (macrolet
3475 ;; ((unordered-check (check)
3476 ;; `(prog1
3477 ;; (setq checked
3478 ;; (or ,check
3479 ;; (prog1 ,(sublis '((x . y) (y . x)) check :test #'eq)
3480 ;; (setq equalp-temp x x y y equalp-temp))))
3481 ;; (when checked
3482 ;; (unless (symbolp y)
3483 ;; (setq let-form `(let ((,equalp-sym ,y))) y equalp-sym))))))
3484 ;; ;; In the bodies of the below clauses, x is always a constant expression
3485 ;; ;; of the type we're interested in, and y is always a symbol that refers
3486 ;; ;; to the result non-constant side of the comparison.
3487 ;; (cond ((unordered-check (and (arrayp x) (not (cl-const-expr-p y))))
3488 ;; ;; Strings and other arrays. A vector containing the same
3489 ;; ;; character elements as a given string is equalp to that string;
3490 ;; ;; a bit-vector can only be equalp to a string if both are
3491 ;; ;; zero-length.
3492 ;; (cond
3493 ;; ((member x '("" #* []))
3494 ;; ;; No need to protect against multiple evaluation here:
3495 ;; `(and (member ,original-y '("" #* [])) t))
3496 ;; ((stringp x)
3497 ;; `(,@let-form
3498 ;; (if (stringp ,y)
3499 ;; (eq t (compare-strings ,x nil nil
3500 ;; ,y nil nil t))
3501 ;; (if (vectorp ,y)
3502 ;; (cl-string-vector-equalp ,x ,y)))))
3503 ;; ((bit-vector-p x)
3504 ;; `(,@let-form
3505 ;; (if (bit-vector-p ,y)
3506 ;; ;; No need to call equalp on each element here:
3507 ;; (equal ,x ,y)
3508 ;; (if (vectorp ,y)
3509 ;; (cl-bit-vector-vector-equalp ,x ,y)))))
3510 ;; (t
3511 ;; (loop
3512 ;; for elt across x
3513 ;; ;; We may not need to check the other argument if it's a
3514 ;; ;; string or bit vector, depending on the contents of x:
3515 ;; always (progn
3516 ;; (unless (characterp elt) (setq check-string nil))
3517 ;; (unless (and (numberp elt) (or (= elt 0) (= elt 1)))
3518 ;; (setq check-bit-vector nil))
3519 ;; (or check-string check-bit-vector)))
3520 ;; `(,@let-form
3521 ;; (cond
3522 ;; ,@(if check-string
3523 ;; `(((stringp ,y)
3524 ;; (cl-string-vector-equalp ,y ,x))))
3525 ;; ,@(if check-bit-vector
3526 ;; `(((bit-vector-p ,y)
3527 ;; (cl-bit-vector-vector-equalp ,y ,x))))
3528 ;; ((vectorp ,y)
3529 ;; (cl-vector-array-equalp ,x ,y)))))))
3530 ;; ((unordered-check (and (characterp x) (not (cl-const-expr-p y))))
3531 ;; `(,@let-form
3532 ;; (or (eq ,x ,y)
3533 ;; ;; eq has a bytecode, char-equal doesn't.
3534 ;; (and (characterp ,y)
3535 ;; (eq (downcase ,x) (downcase ,y))))))
3536 ;; ((unordered-check (and (numberp x) (not (cl-const-expr-p y))))
3537 ;; `(,@let-form
3538 ;; (and (numberp ,y)
3539 ;; (= ,x ,y))))
3540 ;; ((unordered-check (and (hash-table-p x) (not (cl-const-expr-p y))))
3541 ;; ;; Hash tables; follow the CL spec.
3542 ;; `(,@let-form
3543 ;; (and (hash-table-p ,y)
3544 ;; (eq ',(hash-table-test x) (hash-table-test ,y))
3545 ;; (= ,(hash-table-count x) (hash-table-count ,y))
3546 ;; (cl-hash-table-contents-equalp ,x ,y))))
3547 ;; ((unordered-check
3548 ;; ;; Symbols; eq.
3549 ;; (and (not (cl-const-expr-p y))
3550 ;; (or (memq x '(nil t))
3551 ;; (and (eq (car-safe x) 'quote) (symbolp (second x))))))
3552 ;; (cons 'eq (cdr form)))
3553 ;; ((unordered-check
3554 ;; ;; Compare conses at runtime, there's no real upside to
3555 ;; ;; unrolling the function -> they fall through to the next
3556 ;; ;; clause in this function.
3557 ;; (and (cl-const-expr-p x) (not (consp x))
3558 ;; (not (cl-const-expr-p y))))
3559 ;; ;; All other types; use equal.
3560 ;; (cons 'equal (cdr form)))
3561 ;; ;; Neither side is a constant expression, do all our evaluation at
3562 ;; ;; runtime (or both are, and equalp will be called from
3563 ;; ;; byte-optimize.el).
3564 ;; (t form)))))
3470 3565
3471 (define-compiler-macro map (&whole form cl-type cl-func cl-seq 3566 (define-compiler-macro map (&whole form cl-type cl-func cl-seq
3472 &rest cl-rest) 3567 &rest cl-rest)
3473 "If CL-TYPE is a constant expression that we know how to handle, transform 3568 "If CL-TYPE is a constant expression that we know how to handle, transform
3474 the call to `map' to a more efficient expression." 3569 the call to `map' to a more efficient expression."