Mercurial > hg > xemacs-beta

comparison lisp/cl-extra.el @ 5461:568ec109e73d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Check types (unless `byte-compile-delete-errors' is t), #'char<, #'char=, etc. src/ChangeLog addition: 2011-04-23 Aidan Kehoe <kehoea@parhasard.net> * editfns.c: * editfns.c (syms_of_editfns): Implement #'char= in cl-extra.el, not here, accepting more than two arguments as Common Lisp specifies. lisp/ChangeLog addition: 2011-04-23 Aidan Kehoe <kehoea@parhasard.net> * cl-extra.el (define-char-comparisons): Add type-checking when the various character-specific comparison predicates are used; don't check types if byte-compile-delete-errors is non-nil at compile-time, instead use the corresponding built-in numeric byte codes.
author Aidan Kehoe <kehoea@parhasard.net>
date Sat, 23 Apr 2011 22:42:10 +0100
parents aa78b0b0b289
children f2881cb841b4
comparison
equal deleted inserted replaced
5460:82e220b08ace 5461:568ec109e73d
688 (setq x 1e0) 688 (setq x 1e0)
689 (while (/= (- 1e0 x) 1e0) (setq x (/ x 2))) 689 (while (/= (- 1e0 x) 1e0) (setq x (/ x 2)))
690 (setq float-negative-epsilon (* x 2)))))) 690 (setq float-negative-epsilon (* x 2))))))
691 (cl-float-limits)) 691 (cl-float-limits))
692 692
693 ;; No type-checking here, we should add it.
694 (defalias 'char< '<)
695 (defalias 'char>= '>=)
696 (defalias 'char> '>)
697 (defalias 'char<= '<=)
698 693
699 ;;; Character functions. 694 ;;; Character functions.
695 (macrolet
696 ((define-char-comparisons (&rest alist)
697 "Provide Common Lisp's character-specific comparison predicates.
698
699 These throw errors if any arguments are non-characters, conflicting with
700 typical emacs behavior. This is not the case if
701 `byte-compile-delete-errors' is non-nil; see the documentation of that
702 variable.
703
704 This doesn't include the case-insensitive comparisons, and it probably
705 should."
706 (let* ((functions (mapcar 'car alist))
707 (map (mapcar #'(lambda (symbol)
708 `(,symbol .
709 ,(intern (substring (symbol-name symbol)
710 (length "char")))))
711 functions)))
712 `(progn
713 (mapc
714 (function*
715 (lambda ((function . cl-unsafe-comparison))
716 (put function 'cl-unsafe-comparison cl-unsafe-comparison)
717 (put function 'cl-compiler-macro
718 #'(lambda (form &rest arguments)
719 (if byte-compile-delete-errors
720 (cons (get (car form) 'cl-unsafe-comparison)
721 (cdr form))
722 form)))))
723 ',map)
724 ,@(mapcar
725 (function*
726 (lambda ((function . documentation))
727 `(defun ,function (character &rest more-characters)
728 ,documentation
729 (check-type character character)
730 (check-type more-characters
731 (satisfies (lambda (list)
732 (every 'characterp list))))
733 (apply ',(cdr (assq function map))
734 character more-characters))))
735 alist)))))
736 (define-char-comparisons
737 (char= . "Return t if all character arguments are the same object.")
738 (char/= . "Return t if no two character arguments are the same object.")
739 (char< . "Return t if the character arguments monotonically increase.")
740 (char> . "Return t if the character arguments monotonically decrease.")
741 (char<= . "Return t if the character arguments are monotonically \
742 nondecreasing.")
743 (char>= . "Return t if the character arguments are monotonically \
744 nonincreasing.")))
745
700 (defun* digit-char-p (character &optional (radix 10)) 746 (defun* digit-char-p (character &optional (radix 10))
701 "Return non-nil if CHARACTER represents a digit in base RADIX. 747 "Return non-nil if CHARACTER represents a digit in base RADIX.
702 748
703 RADIX defaults to ten. The actual non-nil value returned is the integer 749 RADIX defaults to ten. The actual non-nil value returned is the integer
704 value of the character in base RADIX." 750 value of the character in base RADIX."