[PATCH packages] Implement assoc-string
Jerry James <[email protected]> Mon, 4 Aug 2014 16:38:19 -0600
| Newsgroups | gmane.emacs.xemacs.patches |
|---|---|
| Message-ID | <CAHCOHQk9m6pmDz9HSVoWdGZpvzVc6Y1gEk5m6UNF15b0VwGuDQ@mail.gmail.com> |
PATCH packages Emacs has had a function named assoc-string for about a decade now. We have a couple of packages that have workarounds for our lack of the function. I'm working on a package update that brings in more uses of it. I figured it was time to stop working around its absence. This patch provides a Lisp implementation in xemacs-base/subr-more.el. It is functionally identical to the Emacs version (but not code identical, since the Emacs version is written in C). The patch also removes workarounds from the calendar and leim packages. The patch is attached. -- Jerry James http://www.jamezone.org/ _______________________________________________ XEmacs-Patches mailing list [email protected] http://lists.xemacs.org/mailman/listinfo/xemacs-patches
xemacs-assoc-string.patch
(text/x-patch, 16.1 KB)
diff -r fb24044de5ab mule-packages/leim/ChangeLog --- a/mule-packages/leim/ChangeLog Thu May 15 20:54:17 2014 +0200 +++ b/mule-packages/leim/ChangeLog Mon Aug 04 16:32:44 2014 -0600 @@ -1,3 +1,8 @@ +2014-08-04 Jerry James <[email protected]> + + * quail/sisheng.el (assoc-string): Remove, now available from + xemacs-base. + 2014-05-15 Norbert Koch <[email protected]> * Makefile (VERSION): XEmacs package 1.36 released. @@ -67,8 +72,8 @@ * quail/ipa-21.5.el: Sync these changes from GNU: - 2009-08-31 Juri Linkov <[email protected]> - +2009-08-31 Juri Linkov <[email protected]> + * quail/ipa.el ("ipa"): Set `forget-last-selection' to nil. ("ipa-x-sampa"): Set `forget-last-selection' to nil. Set `deterministic' to nil. @@ -77,9 +82,9 @@ ("ipa-kirshenbaum", ipa-x-sampa"): Bind "g" to U+0261, and "tS" to a list of "U+02A7", "U+0074 U+0283", "U+0074 U+2040 U+0283". Fix comments. - - 2009-08-31 Juri Linkov <[email protected]> - + +2009-08-31 Juri Linkov <[email protected]> + * quail/ipa.el ("ipa-kirshenbaum"): Rename from "kirshenbaum-ipa". ("ipa-x-sampa"): Rename from "x-sampa-ipa". (ipa-x-sampa-implosive-submap): Rename from diff -r fb24044de5ab mule-packages/leim/quail/sisheng.el --- a/mule-packages/leim/quail/sisheng.el Thu May 15 20:54:17 2014 +0200 +++ b/mule-packages/leim/quail/sisheng.el Mon Aug 04 16:32:44 2014 -0600 @@ -31,20 +31,6 @@ (require 'quail) -;; XEmacs change; assoc-string is FSF-specific. -(defun-when-void assoc-string (key list &optional case-fold) - "Like `assoc' but specifically for strings. -Case is ignored if case-fold is non-nil. -As opposed to `assoc', it will also match an entry consisting of a single -string rather than a cons cell whose car is a string." - (block return-assoc-string - (setq key (downcase key)) - (dolist (str list) - (when (equal key (downcase (format "%s" (if (consp str) - (car str) - str)))) - (return-from return-assoc-string str))))) - (defconst sisheng-regexp "[-D犲$(A(5(B]\\|-A-Dｺ")-A diff -r dd6af4aede7f xemacs-packages/calendar/ChangeLog --- a/xemacs-packages/calendar/ChangeLog Thu May 15 20:55:45 2014 +0200 +++ b/xemacs-packages/calendar/ChangeLog Mon Aug 04 16:32:44 2014 -0600 @@ -1,3 +1,22 @@ +2014-08-04 Jerry James <[email protected]> + + * cal-compat.el (cal-assoc-string): Remove, since assoc-string is + now available in xemacs-base. + * cal-bahai.el (mark-bahai-diary-entries): Use assoc-string + instead of cal-assoc-string. + * cal-coptic.el (coptic-prompt-for-date): Ditto. + * cal-french.el (calendar-goto-french-date): Ditto. + * cal-hebrew.el (calendar-goto-hebrew-date): Ditto. + (mark-hebrew-diary-entries): Ditto. + (list-yahrzeit-dates): Ditto. + * cal-islam.el (calendar-goto-islamic-date): Ditto. + (mark-islamic-diary-entries): Ditto. + * cal-julian.el (calendar-goto-julian-date): Ditto. + * cal-mayan.el (calendar-read-mayan-haab-date): Ditto. + (calendar-read-mayan-tzolkin-date): Ditto. + * calendar.el (calendar-read-date): Ditto. + * diary-lib.el (mark-diary-entries): Ditto. + 2014-05-15 Norbert Koch <[email protected]> * Makefile (VERSION): XEmacs package 1.40 released. diff -r dd6af4aede7f xemacs-packages/calendar/cal-bahai.el --- a/xemacs-packages/calendar/cal-bahai.el Thu May 15 20:55:45 2014 +0200 +++ b/xemacs-packages/calendar/cal-bahai.el Mon Aug 04 16:32:44 2014 -0600 @@ -387,8 +387,7 @@ (string-to-number y-str))))) (if dd-name (mark-calendar-days-named - ;; XEmacs change, we don't have assoc-string - (cdr (cal-assoc-string (substring dd-name 0 3) + (cdr (assoc-string (substring dd-name 0 3) (calendar-make-alist calendar-day-name-array 0 @@ -398,8 +397,7 @@ (if (string-equal mm-name "*") (setq mm 0) (setq mm - ;; XEmacs change, we don't have assoc-string - (cdr (cal-assoc-string + (cdr (assoc-string mm-name (calendar-make-alist bahai-calendar-month-name-array) diff -r dd6af4aede7f xemacs-packages/calendar/cal-compat.el --- a/xemacs-packages/calendar/cal-compat.el Thu May 15 20:55:45 2014 +0200 +++ b/xemacs-packages/calendar/cal-compat.el Mon Aug 04 16:32:44 2014 -0600 @@ -69,15 +69,6 @@ (setq buffer-invisibility-spec (cons arg buffer-invisibility-spec)))) -;;;###autoload -(if (fboundp 'assoc-string) - (defalias 'cal-assoc-string 'assoc-string) - (defun cal-assoc-string (key list case-fold) - (if case-fold - (assoc-ignore-case key list) - (assoc key list))) - ) - ;; XEmacs change ;; not available until 21.5 ;;;###autoload diff -r dd6af4aede7f xemacs-packages/calendar/cal-coptic.el --- a/xemacs-packages/calendar/cal-coptic.el Thu May 15 20:55:45 2014 +0200 +++ b/xemacs-packages/calendar/cal-coptic.el Mon Aug 04 16:32:44 2014 -0600 @@ -157,8 +157,7 @@ (calendar-coptic-from-absolute (calendar-absolute-from-gregorian today)))))) (completion-ignore-case t) - ;; XEmacs change, we don't have assoc-string - (month (cdr (cal-assoc-string + (month (cdr (assoc-string (completing-read (format "%s calendar month name: " coptic-name) (mapcar 'list diff -r dd6af4aede7f xemacs-packages/calendar/cal-french.el --- a/xemacs-packages/calendar/cal-french.el Thu May 15 20:55:45 2014 +0200 +++ b/xemacs-packages/calendar/cal-french.el Mon Aug 04 16:32:44 2014 -0600 @@ -235,8 +235,7 @@ (concat "Jour " x)) special-days)))))))) (completion-ignore-case t) - ;; XEmacs change, we don't have assoc-string - (month (cdr (cal-assoc-string + (month (cdr (assoc-string (completing-read "Mois ou Sansculottide: " month-list diff -r dd6af4aede7f xemacs-packages/calendar/cal-hebrew.el --- a/xemacs-packages/calendar/cal-hebrew.el Thu May 15 20:55:45 2014 +0200 +++ b/xemacs-packages/calendar/cal-hebrew.el Mon Aug 04 16:32:44 2014 -0600 @@ -244,16 +244,14 @@ calendar-hebrew-month-name-array-leap-year calendar-hebrew-month-name-array-common-year)) (completion-ignore-case t) - ;; XEmacs change, we don't have assoc-string - (month (cdr (cal-assoc-string + (month (cdr (assoc-string (completing-read "Hebrew calendar month name: " (mapcar 'list (append month-array nil)) (if (= year 3761) '(lambda (x) (let ((m (cdr - ;; XEmacs change, we don't have assoc-string - (cal-assoc-string + (assoc-string (car x) (calendar-make-alist month-array) t)))) @@ -763,17 +761,15 @@ (string-to-number y-str))))) (if dd-name (mark-calendar-days-named - ;; XEmacs change, we don't have assoc-string - (cdr (cal-assoc-string dd-name - (calendar-make-alist - calendar-day-name-array - 0 nil calendar-day-abbrev-array) t))) + (cdr (assoc-string dd-name + (calendar-make-alist + calendar-day-name-array + 0 nil calendar-day-abbrev-array) t))) (if mm-name (setq mm (if (string-equal mm-name "*") 0 (cdr - ;; XEmacs change, we don't have assoc-string - (cal-assoc-string + (assoc-string mm-name (calendar-make-alist calendar-hebrew-month-name-array-leap-year) t))))) @@ -851,8 +847,7 @@ (int-to-string (extract-calendar-year today)))) (month-array calendar-month-name-array) (completion-ignore-case t) - ;; XEmacs change, we don't have assoc-string - (month (cdr (cal-assoc-string + (month (cdr (assoc-string (completing-read "Month of death (name): " (mapcar 'list (append month-array nil)) diff -r dd6af4aede7f xemacs-packages/calendar/cal-islam.el --- a/xemacs-packages/calendar/cal-islam.el Thu May 15 20:55:45 2014 +0200 +++ b/xemacs-packages/calendar/cal-islam.el Mon Aug 04 16:32:44 2014 -0600 @@ -161,8 +161,7 @@ (calendar-absolute-from-gregorian today)))))) (month-array calendar-islamic-month-name-array) (completion-ignore-case t) - ;; XEmacs change, we don't have assoc-string - (month (cdr (cal-assoc-string + (month (cdr (assoc-string (completing-read "Islamic calendar month name: " (mapcar 'list (append month-array nil)) @@ -380,15 +379,13 @@ (string-to-number y-str))))) (if dd-name (mark-calendar-days-named - ;; XEmacs change, we don't have assoc-string - (cdr (cal-assoc-string dd-name - (calendar-make-alist - calendar-day-name-array - 0 nil calendar-day-abbrev-array) t))) + (cdr (assoc-string dd-name + (calendar-make-alist + calendar-day-name-array + 0 nil calendar-day-abbrev-array) t))) (if mm-name (setq mm (if (string-equal mm-name "*") 0 - ;; XEmacs change, we don't have assoc-string - (cdr (cal-assoc-string + (cdr (assoc-string mm-name (calendar-make-alist calendar-islamic-month-name-array) t))))) diff -r dd6af4aede7f xemacs-packages/calendar/cal-julian.el --- a/xemacs-packages/calendar/cal-julian.el Thu May 15 20:55:45 2014 +0200 +++ b/xemacs-packages/calendar/cal-julian.el Mon Aug 04 16:32:44 2014 -0600 @@ -120,8 +120,7 @@ today)))))) (month-array calendar-month-name-array) (completion-ignore-case t) - ;; XEmacs change, we don't have assoc-string - (month (cdr (cal-assoc-string + (month (cdr (assoc-string (completing-read "Julian calendar month name: " (mapcar 'list (append month-array nil)) diff -r dd6af4aede7f xemacs-packages/calendar/cal-mayan.el --- a/xemacs-packages/calendar/cal-mayan.el Thu May 15 20:55:45 2014 +0200 +++ b/xemacs-packages/calendar/cal-mayan.el Mon Aug 04 16:32:44 2014 -0600 @@ -262,8 +262,7 @@ (haab-month-list (append calendar-mayan-haab-month-name-array (and (< haab-day 5) '("Uayeb")))) (haab-month (cdr - ;; XEmacs change, we don't have assoc-string - (cal-assoc-string + (assoc-string (completing-read "Haab uinal: " (mapcar 'list haab-month-list) nil t) @@ -278,8 +277,7 @@ '(lambda (x) (and (> x 0) (< x 14))))) (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil)) (tzolkin-name (cdr - ;; XEmacs change, we don't have assoc-string - (cal-assoc-string + (assoc-string (completing-read "Tzolkin uinal: " (mapcar 'list tzolkin-name-list) nil t) diff -r dd6af4aede7f xemacs-packages/calendar/calendar.el --- a/xemacs-packages/calendar/calendar.el Thu May 15 20:55:45 2014 +0200 +++ b/xemacs-packages/calendar/calendar.el Mon Aug 04 16:32:44 2014 -0600 @@ -2782,8 +2782,7 @@ (calendar-current-date))))) (month-array calendar-month-name-array) (completion-ignore-case t) - ;; XEmacs change, we don't have assoc-string - (month (cdr (cal-assoc-string + (month (cdr (assoc-string (completing-read "Month name: " (mapcar 'list (append month-array nil)) diff -r dd6af4aede7f xemacs-packages/calendar/diary-lib.el --- a/xemacs-packages/calendar/diary-lib.el Thu May 15 20:55:45 2014 +0200 +++ b/xemacs-packages/calendar/diary-lib.el Mon Aug 04 16:32:44 2014 -0600 @@ -1055,8 +1055,7 @@ marks (nth 1 tmp))) (if dd-name (mark-calendar-days-named - ;; XEmacs change, we don't have assoc-string - (cdr (cal-assoc-string + (cdr (assoc-string dd-name (calendar-make-alist calendar-day-name-array @@ -1064,8 +1063,7 @@ (if mm-name (setq mm (if (string-equal mm-name "*") 0 - ;; XEmacs change, we don't have assoc-string - (cdr (cal-assoc-string + (cdr (assoc-string mm-name (calendar-make-alist calendar-month-name-array diff -r 06f247e269bf xemacs-packages/xemacs-base/ChangeLog --- a/xemacs-packages/xemacs-base/ChangeLog Thu May 15 21:14:23 2014 +0200 +++ b/xemacs-packages/xemacs-base/ChangeLog Mon Aug 04 16:32:45 2014 -0600 @@ -1,3 +1,7 @@ +2014-08-04 Jerry James <[email protected]> + + * subr-more.el (assoc-string): New function from GNU Emacs. + 2014-05-15 Norbert Koch <[email protected]> * Makefile (VERSION): XEmacs package 2.41 released. diff -r 06f247e269bf xemacs-packages/xemacs-base/subr-more.el --- a/xemacs-packages/xemacs-base/subr-more.el Thu May 15 21:14:23 2014 +0200 +++ b/xemacs-packages/xemacs-base/subr-more.el Mon Aug 04 16:32:45 2014 -0600 @@ -171,4 +171,28 @@ (progn ,@body) (error (message "Error: %S" ,err) nil)))) +;;;###autoload +(defun assoc-string (key list &optional case-fold) + "Like `assoc' but specifically for strings (and symbols). + +This returns the first element of LIST whose car matches the string or +symbol KEY, or NIL if no match exists. When performing the comparison, +symbols are first converted to strings. If the optional arg CASE-FOLD +is non-nil, case is ignored. + +Unlike `assoc', KEY can also match an entry in LIST consisting of a +single string, rather than a cons cell whose car is a string." + (when (symbolp key) + (setq key (symbol-name key))) + (let* ((tail list) elt elt2 elt3 result) + (while (and (null result) tail) + (setq elt (car tail) + elt2 (if (consp elt) (car elt) elt) + elt3 (if (symbolp elt2) (symbol-name elt2) elt2) + result (and (stringp elt3) + (eq (compare-strings elt3 0 nil key 0 nil case-fold) t) + elt) + tail (cdr tail))) + result)) + ;;; subr-more.el ends here