From: Stefan Monnier Date: Mon, 20 Dec 2021 16:04:37 +0000 (-0500) Subject: Fix bug#28557 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=20e5cd82aec81a411dd5e4fd880cccc8dabe3455;p=emacs.git Fix bug#28557 * test/lisp/emacs-lisp/cconv-tests.el: Remove `:expected-result :failed` from the bug#28557 tests. (cconv-tests-cl-function-:documentation): Account for the presence of the arglist (aka "usage") in the docstring. * lisp/emacs-lisp/cl-macs.el (cl--transform-lambda): * lisp/emacs-lisp/cl-generic.el (cl-defgeneric): Handle non-constant `:documentation`. * lisp/emacs-lisp/generator.el (iter-lambda): * lisp/emacs-lisp/oclosure.el (oclosure-lambda): * lisp/emacs-lisp/cconv.el (cconv--convert-funcbody): Use `macroexp-parse-body`. * lisp/calendar/icalendar.el (icalendar--decode-isodatetime): Fix misuse of `cl-lib` without requiring it. --- diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 7a483d40627..01387341d65 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -645,10 +645,10 @@ FIXME: multiple comma-separated values should be allowed!" (setq second (read (substring isodatetimestring 13 15)))) ;; FIXME: Support subseconds. (when (> (length isodatetimestring) 15) - (cl-case (aref isodatetimestring 15) + (pcase (aref isodatetimestring 15) (?Z (setq source-zone t)) - ((?- ?+) + ((or ?- ?+) (setq source-zone (concat "UTC" (substring isodatetimestring 15)))))) ;; shift if necessary diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 97066da0ee7..66e0c359415 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -294,15 +294,10 @@ of converted forms." (cconv-convert form env nil)) funcbody)) (if wrappers - (let ((special-forms '())) - ;; Keep special forms at the beginning of the body. - (while (or (and (cdr funcbody) (stringp (car funcbody))) ;docstring. - (memq (car-safe (car funcbody)) - '(interactive declare :documentation))) - (push (pop funcbody) special-forms)) - (let ((body (macroexp-progn funcbody))) + (pcase-let ((`(,decls . ,body) (macroexp-parse-body funcbody))) + (let ((body (macroexp-progn body))) (dolist (wrapper wrappers) (setq body (funcall wrapper body))) - `(,@(nreverse special-forms) ,@(macroexp-unprogn body)))) + `(,@decls ,@(macroexp-unprogn body)))) funcbody))) (defun cconv--lifted-arg (var env) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 44018da30e1..1886f309e34 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -286,7 +286,9 @@ DEFAULT-BODY, if present, is used as the body of a default method. (progn (defalias ',name (cl-generic-define ',name ',args ',(nreverse options)) - ,(help-add-fundoc-usage doc args)) + ,(if (consp doc) ;An expression rather than a constant. + `(docstring-add-fundoc-usage ,doc ',args) + (docstring-add-fundoc-usage doc args))) :autoload-end ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) (nreverse methods))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 6bd0d0c3283..96559fbfb6e 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -301,24 +301,33 @@ FORM is of the form (ARGS . BODY)." (t ;; `simple-args' doesn't handle all the parsing that we need, ;; so we pass the rest to cl--do-arglist which will do ;; "manual" parsing. - (let ((slen (length simple-args))) - (when (memq '&optional simple-args) - (cl-decf slen)) - (setq header + (let ((slen (length simple-args)) + (usage-str ;; Macro expansion can take place in the middle of ;; apparently harmless computation, so it should not ;; touch the match-data. (save-match-data + (docstring--quote + (let ((print-gensym nil) (print-quoted t) + (print-escape-newlines t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args)))))))) + (when (memq '&optional simple-args) + (cl-decf slen)) + (setq header + (cond + ((eq :documentation (caar header)) + `((:documentation (docstring-add-fundoc-usage + ,(cadr (car header)) + ,usage-str)) + ,@(cdr header))) + (t (cons (docstring-add-fundoc-usage (if (stringp (car header)) (pop header)) ;; Be careful with make-symbol and (back)quote, ;; see bug#12884. - (docstring--quote - (let ((print-gensym nil) (print-quoted t) - (print-escape-newlines t)) - (format "%S" (cons 'fn (cl--make-usage-args - orig-args)))))) - header))) + usage-str) + header)))) ;; FIXME: we'd want to choose an arg name for the &rest param ;; and pass that as `expr' to cl--do-arglist, but that ends up ;; generating code with a redundant let-binding, so we instead diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index cb0241017a0..a768c6ae832 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -692,8 +692,10 @@ of values. Callers can retrieve each value using `iter-next'." (declare (indent defun) (debug (&define lambda-list lambda-doc &rest sexp))) (cl-assert lexical-binding) - `(lambda ,arglist - ,(cps-generate-evaluator body))) + (pcase-let* ((`(,declarations . ,exps) (macroexp-parse-body body))) + `(lambda ,arglist + ,@declarations + ,(cps-generate-evaluator exps)))) (defmacro iter-make (&rest body) "Return a new iterator." diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index ea6b4d73d3c..3a1c4a2a580 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -484,6 +484,8 @@ is defined as a macro, alias, command, ..." (get symbol 'advice--pending)) (t (symbol-function symbol))) function props) + ;; FIXME: We could use a defmethod on `function-docstring' instead, + ;; except when (or (not nf) (autoloadp nf))! (put symbol 'function-documentation `(advice--make-docstring ',symbol)) (add-function :around (get symbol 'defalias-fset-function) #'advice--defalias-fset)) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index f8ed5bfa394..3462e62a43c 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -187,33 +187,34 @@ (defmacro oclosure-lambda (type fields args &rest body) (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body))) - ;; FIXME: Provide the fields in the order specified by `type'. - (let* ((class (cl--find-class type)) - (slots (oclosure--class-slots class)) - (prebody '()) - (slotbinds (nreverse - (mapcar (lambda (slot) - (list (cl--slot-descriptor-name slot))) - slots))) - (tempbinds (mapcar - (lambda (field) - (let* ((name (car field)) - (bind (assq name slotbinds))) - (cond - ((not bind) - (error "Unknown slots: %S" name)) - ((cdr bind) - (error "Duplicate slots: %S" name)) - (t - (let ((temp (gensym "temp"))) - (setcdr bind (list temp)) - (cons temp (cdr field))))))) - fields))) - ;; FIXME: Since we use the docstring internally to store the - ;; type we can't handle actual docstrings. We could fix this by adding - ;; a docstring slot to OClosures. - (while (memq (car-safe (car-safe body)) '(interactive declare)) - (push (pop body) prebody)) + ;; FIXME: Should `oclosure-define' distinguish "optional" from + ;; "mandatory" slots, and/or provide default values for slots missing + ;; from `fields'? + (pcase-let* + ((class (cl--find-class type)) + (slots (oclosure--class-slots class)) + ;; FIXME: Since we use the docstring internally to store the + ;; type we can't handle actual docstrings. We could fix this by adding + ;; a docstring slot to OClosures. + (`(,prebody . ,body) (macroexp-parse-body body)) + (slotbinds (nreverse + (mapcar (lambda (slot) + (list (cl--slot-descriptor-name slot))) + slots))) + (tempbinds (mapcar + (lambda (field) + (let* ((name (car field)) + (bind (assq name slotbinds))) + (cond + ((not bind) + (error "Unknown slots: %S" name)) + ((cdr bind) + (error "Duplicate slots: %S" name)) + (t + (let ((temp (gensym "temp"))) + (setcdr bind (list temp)) + (cons temp (cdr field))))))) + fields))) ;; FIXME: Optimize temps away when they're provided in the right order? ;; FIXME: Slots not specified in `fields' tend to emit "Variable FOO left ;; uninitialized"! diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 0701892b8c4..d7f9af18994 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -83,9 +83,6 @@ (iter-yield 'cl-iter-defun-result)) (ert-deftest cconv-tests-cl-iter-defun-:documentation () "Docstring for cl-iter-defun can be specified with :documentation." - ;; FIXME: See Bug#28557. - :tags '(:unstable) - :expected-result :failed (should (string= (documentation 'cconv-tests-cl-iter-defun) "cl-iter-defun documentation")) (should (eq (iter-next (cconv-tests-cl-iter-defun)) @@ -96,17 +93,12 @@ (iter-yield 'iter-defun-result)) (ert-deftest cconv-tests-iter-defun-:documentation () "Docstring for iter-defun can be specified with :documentation." - ;; FIXME: See Bug#28557. - :tags '(:unstable) - :expected-result :failed (should (string= (documentation 'cconv-tests-iter-defun) "iter-defun documentation")) (should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result))) (ert-deftest cconv-tests-iter-lambda-:documentation () "Docstring for iter-lambda can be specified with :documentation." - ;; FIXME: See Bug#28557. - :expected-result :failed (let ((iter-fun (iter-lambda () (:documentation (concat "iter-lambda" " documentation")) @@ -116,13 +108,11 @@ (ert-deftest cconv-tests-cl-function-:documentation () "Docstring for cl-function can be specified with :documentation." - ;; FIXME: See Bug#28557. - :expected-result :failed (let ((fun (cl-function (lambda (&key arg) (:documentation (concat "cl-function" " documentation")) (list arg 'cl-function-result))))) - (should (string= (documentation fun) "cl-function documentation")) + (should (string-match "\\`cl-function documentation$" (documentation fun))) (should (equal (funcall fun :arg t) '(t cl-function-result))))) (ert-deftest cconv-tests-function-:documentation () @@ -142,8 +132,6 @@ (+ 1 n)) (ert-deftest cconv-tests-cl-defgeneric-:documentation () "Docstring for cl-defgeneric can be specified with :documentation." - ;; FIXME: See Bug#28557. - :expected-result :failed (let ((descr (describe-function 'cconv-tests-cl-defgeneric))) (set-text-properties 0 (length descr) nil descr) (should (string-match-p "cl-defgeneric documentation" descr))