[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/fcr 734e1bc: Fix bug#28557
From: |
Stefan Monnier |
Subject: |
scratch/fcr 734e1bc: Fix bug#28557 |
Date: |
Mon, 20 Dec 2021 11:04:49 -0500 (EST) |
branch: scratch/fcr
commit 734e1bcc16fa690247af57c1e7b89ccc18ca1f6d
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
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/fcr.el (fcr-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.
---
lisp/calendar/icalendar.el | 4 +--
lisp/emacs-lisp/cconv.el | 11 ++------
lisp/emacs-lisp/cl-generic.el | 4 ++-
lisp/emacs-lisp/cl-macs.el | 29 ++++++++++++-------
lisp/emacs-lisp/fcr.el | 55 +++++++++++++++++++------------------
lisp/emacs-lisp/generator.el | 6 ++--
lisp/emacs-lisp/nadvice.el | 2 ++
test/lisp/emacs-lisp/cconv-tests.el | 14 +---------
8 files changed, 62 insertions(+), 63 deletions(-)
diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el
index 7a483d4..0138734 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 d1c7bc0..4fdcf2b 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 643c006..f6643c1 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 6bd0d0c..96559fb 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/fcr.el b/lisp/emacs-lisp/fcr.el
index 8f01d56..548348a 100644
--- a/lisp/emacs-lisp/fcr.el
+++ b/lisp/emacs-lisp/fcr.el
@@ -187,33 +187,34 @@
(defmacro fcr-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 (fcr--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 FCRs.
- (while (memq (car-safe (car-safe body)) '(interactive declare))
- (push (pop body) prebody))
+ ;; FIXME: Should `fcr-defstruct' distinguish "optional" from
+ ;; "mandatory" slots, and/or provide default values for slots missing
+ ;; from `fields'?
+ (pcase-let*
+ ((class (cl--find-class type))
+ (slots (fcr--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 FCRs.
+ (`(,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/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el
index cb02410..a768c6a 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 b07bc74..36f9a05 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/test/lisp/emacs-lisp/cconv-tests.el
b/test/lisp/emacs-lisp/cconv-tests.el
index 0701892..d7f9af1 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))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- scratch/fcr 734e1bc: Fix bug#28557,
Stefan Monnier <=