(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
(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)
(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)))
(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
(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"!
(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."
(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))
(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))
(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"))
(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 ()
(+ 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))
projects / emacs.git / commitdiff