master d8a9828 2/5: * lisp/calendar/calendar.el (calendar-read-sexp): New function

[Stefan Monnier]

branch: master
commit d8a9828b3b7c5d80ecc57089e0c93c4dfa6837b7
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * lisp/calendar/calendar.el (calendar-read-sexp): New function
    
    (calendar-read): Mark as obsolete.
    (calendar-read-date): Use it.  Add `default-date` argument.
    Provide defaults for the month and day (fixes bug#32105).
---
 lisp/calendar/calendar.el | 57 ++++++++++++++++++++++++++++++++++-------------
 1 file changed, 41 insertions(+), 16 deletions(-)

diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el
index 21cea21..3f9fe1c 100644
--- a/lisp/calendar/calendar.el
+++ b/lisp/calendar/calendar.el
@@ -112,6 +112,8 @@
 
 ;;; Code:
 
+(eval-when-compile (require 'subr-x))
+
 (load "cal-loaddefs" nil t)
 
 ;; Calendar has historically relied heavily on dynamic scoping.
@@ -1459,7 +1461,7 @@ Optional integers MON and YR are used instead of today's 
date."
 Inserts STRING so that it ends at INDENT.  STRING is either a
 literal string, or a sexp to evaluate to return such.  Truncates
 STRING to length TRUNCATE, and ensures a trailing space."
-  (if (not (ignore-errors (stringp (setq string (eval string)))))
+  (if (not (ignore-errors (stringp (setq string (eval string t)))))
       (calendar-move-to-column indent)
     (if (> (string-width string) truncate)
         (setq string (truncate-string-to-width string truncate)))
@@ -1526,7 +1528,7 @@ first INDENT characters on the line."
               (format (format "%%%dd" calendar-day-digit-width) day)
               'mouse-face 'highlight
               'help-echo (calendar-dlet* ((day day) (month month) (year year))
-                           (eval calendar-date-echo-text))
+                           (eval calendar-date-echo-text t))
               ;; 'date property prevents intermonth text confusing re-searches.
               ;; (Tried intangible, it did not really work.)
               'date t)
@@ -2054,23 +2056,40 @@ With argument ARG, jump to mark, pop it, and put point 
at end of ring."
   (error "%s not available in the calendar"
          (global-key-binding (this-command-keys))))
 
+(defun calendar-read-sexp (prompt predicate &optional default &rest args)
+  "Return an object read from the minibuffer.
+Passes PROMPT, DEFAULT, and ARGS to `format-prompt' to build
+the actual prompt.  PREDICATE is called with a single value (the object
+the user entered) and it should return non-nil if that value is a valid choice.
+DEFAULT is the default value to use."
+  (unless (stringp default) (setq default (format "%S" default)))
+  (named-let query ()
+    ;; The call to `read-from-minibuffer' is copied from `read-minibuffer',
+    ;; except it's changed to use the DEFAULT arg instead of INITIAL-CONTENTS.
+    (let ((value (read-from-minibuffer
+                  (apply #'format-prompt prompt default args)
+                  nil minibuffer-local-map t 'minibuffer-history default)))
+      (if (funcall predicate value)
+          value
+        (query)))))
+
 (defun calendar-read (prompt acceptable &optional initial-contents)
   "Return an object read from the minibuffer.
 Prompt with the string PROMPT and use the function ACCEPTABLE to decide
 if entered item is acceptable.  If non-nil, optional third arg
 INITIAL-CONTENTS is a string to insert in the minibuffer before reading."
+  (declare (obsolete calendar-read-sexp "28.1"))
   (let ((value (read-minibuffer prompt initial-contents)))
     (while (not (funcall acceptable value))
       (setq value (read-minibuffer prompt initial-contents)))
     value))
 
-
 (defun calendar-customized-p (symbol)
   "Return non-nil if SYMBOL has been customized."
   (and (default-boundp symbol)
        (let ((standard (get symbol 'standard-value)))
          (and standard
-              (not (equal (eval (car standard)) (default-value symbol)))))))
+              (not (equal (eval (car standard) t) (default-value symbol)))))))
 
 (defun calendar-abbrev-construct (full &optional maxlen)
   "From sequence FULL, return a vector of abbreviations.
@@ -2284,32 +2303,38 @@ arguments SEQUENCES."
           (append (list sequence) sequences))
     (reverse alist)))
 
-(defun calendar-read-date (&optional noday)
+(defun calendar-read-date (&optional noday default-date)
   "Prompt for Gregorian date.  Return a list (month day year).
 If optional NODAY is t, does not ask for day, but just returns
 \(month 1 year); if NODAY is any other non-nil value the value
 returned is (month year)."
-  (let* ((year (calendar-read
-                "Year (>0): "
-                (lambda (x) (> x 0))
-                (number-to-string (calendar-extract-year
-                                (calendar-current-date)))))
+  (unless default-date (setq default-date (calendar-current-date)))
+  (let* ((defyear (calendar-extract-year default-date))
+         (year (calendar-read-sexp "Year (>0)"
+                                   (lambda (x) (> x 0))
+                                   defyear))
          (month-array calendar-month-name-array)
+         (defmon (aref month-array (1- (calendar-extract-month default-date))))
          (completion-ignore-case t)
          (month (cdr (assoc-string
-                       (completing-read
-                        "Month name: "
-                        (mapcar #'list (append month-array nil))
-                        nil t)
+                      (completing-read
+                       (format-prompt "Month name" defmon)
+                       (append month-array nil)
+                       nil t nil nil defmon)
                       (calendar-make-alist month-array 1) t)))
+         (defday (calendar-extract-day default-date))
          (last (calendar-last-day-of-month month year)))
     (if noday
         (if (eq noday t)
             (list month 1 year)
           (list month year))
       (list month
-            (calendar-read (format "Day (1-%d): " last)
-                           (lambda (x) (and (< 0 x) (<= x last))))
+            (calendar-read-sexp "Day (1-%d)"
+                                (lambda (x) (and (< 0 x) (<= x last)))
+                                ;; Don't offer today's day as default
+                                ;; if it's not valid for the chosen
+                                ;; month/year.
+                                (if (<= defday last) defday) last)
             year))))
 
 (defun calendar-interval (mon1 yr1 mon2 yr2)