(list 'function-put (list 'quote name)
''no-font-lock-keyword (list 'quote val))))
+(defalias 'byte-run--parse-body
+ #'(lambda (body allow-interactive)
+ "Decompose BODY into (DOCSTRING DECLARE INTERACTIVE BODY-REST WARNINGS)."
+ (let* ((top body)
+ (docstring nil)
+ (declare-form nil)
+ (interactive-form nil)
+ (warnings nil)
+ (warn #'(lambda (msg form)
+ (push (macroexp-warn-and-return msg nil nil t form)
+ warnings))))
+ (while
+ (and body
+ (let* ((form (car body))
+ (head (car-safe form)))
+ (cond
+ ((or (and (stringp form) (cdr body))
+ (eq head :documentation))
+ (cond
+ (docstring (funcall warn "More than one doc string" top))
+ (declare-form
+ (funcall warn "Doc string after `declare'" declare-form))
+ (interactive-form
+ (funcall warn "Doc string after `interactive'"
+ interactive-form))
+ (t (setq docstring form)))
+ t)
+ ((eq head 'declare)
+ (cond
+ (declare-form
+ (funcall warn "More than one `declare' form" form))
+ (interactive-form
+ (funcall warn "`declare' after `interactive'" form))
+ (t (setq declare-form form)))
+ t)
+ ((eq head 'interactive)
+ (cond
+ ((not allow-interactive)
+ (funcall warn "No `interactive' form allowed here" form))
+ (interactive-form
+ (funcall warn "More than one `interactive' form" form))
+ (t (setq interactive-form form)))
+ t))))
+ (setq body (cdr body)))
+ (list docstring declare-form interactive-form body warnings))))
+
+(defalias 'byte-run--parse-declarations
+ #'(lambda (name arglist clauses construct declarations-alist)
+ (let* ((cl-decls nil)
+ (actions
+ (mapcar
+ #'(lambda (x)
+ (let ((f (cdr (assq (car x) declarations-alist))))
+ (cond
+ (f (apply (car f) name arglist (cdr x)))
+ ;; Yuck!!
+ ((and (featurep 'cl)
+ (memq (car x) ;C.f. cl--do-proclaim.
+ '(special inline notinline optimize warn)))
+ (push (list 'declare x) cl-decls)
+ nil)
+ (t
+ (macroexp-warn-and-return
+ (format-message "Unknown %s property `%S'"
+ construct (car x))
+ nil nil nil (car x))))))
+ clauses)))
+ (cons actions cl-decls))))
+
(defvar macro-declarations-alist
(cons
(list 'debug #'byte-run--set-debug)
(defalias 'defmacro
(cons
'macro
- #'(lambda (name arglist &optional docstring &rest body)
+ #'(lambda (name arglist &rest body)
"Define NAME as a macro.
When the macro is called, as in (NAME ARGS...),
the function (lambda ARGLIST BODY...) is applied to
interpreted according to `macro-declarations-alist'.
The return value is undefined.
-\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)"
- ;; We can't just have `decl' as an &optional argument, because we need
- ;; to distinguish
- ;; (defmacro foo (arg) (bar) nil)
- ;; from
- ;; (defmacro foo (arg) (bar)).
- (let ((decls (cond
- ((eq (car-safe docstring) 'declare)
- (prog1 (cdr docstring) (setq docstring nil)))
- ((and (stringp docstring)
- (eq (car-safe (car body)) 'declare))
- (prog1 (cdr (car body)) (setq body (cdr body)))))))
- (if docstring (setq body (cons docstring body))
- (if (null body) (setq body '(nil))))
- ;; Can't use backquote because it's not defined yet!
- (let* ((fun (list 'function (cons 'lambda (cons arglist body))))
- (def (list 'defalias
- (list 'quote name)
- (list 'cons ''macro fun)))
- (declarations
- (mapcar
- #'(lambda (x)
- (let ((f (cdr (assq (car x) macro-declarations-alist))))
- (if f (apply (car f) name arglist (cdr x))
- (macroexp-warn-and-return
- (format-message
- "Unknown macro property %S in %S"
- (car x) name)
- nil nil nil (car x)))))
- decls)))
- ;; Refresh font-lock if this is a new macro, or it is an
- ;; existing macro whose 'no-font-lock-keyword declaration
- ;; has changed.
- (if (and
- ;; If lisp-mode hasn't been loaded, there's no reason
- ;; to flush.
- (fboundp 'lisp--el-font-lock-flush-elisp-buffers)
- (or (not (fboundp name)) ;; new macro
- (and (fboundp name) ;; existing macro
- (member `(function-put ',name 'no-font-lock-keyword
- ',(get name 'no-font-lock-keyword))
- declarations))))
- (lisp--el-font-lock-flush-elisp-buffers))
- (if declarations
- (cons 'prog1 (cons def declarations))
+\(fn NAME ARGLIST [DOCSTRING] [DECL] BODY...)"
+ (let* ((parse (byte-run--parse-body body nil))
+ (docstring (nth 0 parse))
+ (declare-form (nth 1 parse))
+ (body (nth 3 parse))
+ (warnings (nth 4 parse))
+ (declarations
+ (and declare-form (byte-run--parse-declarations
+ name arglist (cdr declare-form) 'macro
+ macro-declarations-alist))))
+ (setq body (nconc warnings body))
+ (setq body (nconc (cdr declarations) body))
+ (if docstring
+ (setq body (cons docstring body)))
+ (if (null body)
+ (setq body '(nil)))
+ (let* ((fun (list 'function (cons 'lambda (cons arglist body))))
+ (def (list 'defalias
+ (list 'quote name)
+ (list 'cons ''macro fun))))
+ (if declarations
+ (cons 'prog1 (cons def (car declarations)))
def))))))
;; Now that we defined defmacro we can use it!
-(defmacro defun (name arglist &optional docstring &rest body)
+(defmacro defun (name arglist &rest body)
"Define NAME as a function.
-The definition is (lambda ARGLIST [DOCSTRING] BODY...).
-See also the function `interactive'.
+The definition is (lambda ARGLIST [DOCSTRING] [INTERACTIVE] BODY...).
DECL is a declaration, optional, of the form (declare DECLS...) where
DECLS is a list of elements of the form (PROP . VALUES). These are
interpreted according to `defun-declarations-alist'.
+INTERACTIVE is an optional `interactive' specification.
The return value is undefined.
-\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)"
- ;; We can't just have `decl' as an &optional argument, because we need
- ;; to distinguish
- ;; (defun foo (arg) (toto) nil)
- ;; from
- ;; (defun foo (arg) (toto)).
+\(fn NAME ARGLIST [DOCSTRING] [DECL] [INTERACTIVE] BODY...)"
(declare (doc-string 3) (indent 2))
(or name (error "Cannot define '%s' as a function" name))
(if (null
(and (listp arglist)
(null (delq t (mapcar #'symbolp arglist)))))
(error "Malformed arglist: %s" arglist))
- (let ((decls (cond
- ((eq (car-safe docstring) 'declare)
- (prog1 (cdr docstring) (setq docstring nil)))
- ((and (stringp docstring)
- (eq (car-safe (car body)) 'declare))
- (prog1 (cdr (car body)) (setq body (cdr body)))))))
- (if docstring (setq body (cons docstring body))
- (if (null body) (setq body '(nil))))
- (let ((declarations
- (mapcar
- #'(lambda (x)
- (let ((f (cdr (assq (car x) defun-declarations-alist))))
- (cond
- (f (apply (car f) name arglist (cdr x)))
- ;; Yuck!!
- ((and (featurep 'cl)
- (memq (car x) ;C.f. cl-do-proclaim.
- '(special inline notinline optimize warn)))
- (push (list 'declare x)
- (if (stringp docstring)
- (if (eq (car-safe (cadr body)) 'interactive)
- (cddr body)
- (cdr body))
- (if (eq (car-safe (car body)) 'interactive)
- (cdr body)
- body)))
- nil)
- (t
- (macroexp-warn-and-return
- (format-message "Unknown defun property `%S' in %S"
- (car x) name)
- nil nil nil (car x))))))
- decls))
- (def (list 'defalias
+ (let* ((parse (byte-run--parse-body body t))
+ (docstring (nth 0 parse))
+ (declare-form (nth 1 parse))
+ (interactive-form (nth 2 parse))
+ (body (nth 3 parse))
+ (warnings (nth 4 parse))
+ (declarations
+ (and declare-form (byte-run--parse-declarations
+ name arglist (cdr declare-form) 'defun
+ defun-declarations-alist))))
+ (setq body (nconc warnings body))
+ (setq body (nconc (cdr declarations) body))
+ (if interactive-form
+ (setq body (cons interactive-form body)))
+ (if docstring
+ (setq body (cons docstring body)))
+ (if (null body)
+ (setq body '(nil)))
+ (let ((def (list 'defalias
(list 'quote name)
(list 'function
(cons 'lambda
(cons arglist body))))))
(if declarations
- (cons 'prog1 (cons def declarations))
- def))))
+ (cons 'prog1 (cons def (car declarations)))
+ def))))
\f
;; Redefined in byte-opt.el.
--- /dev/null
+;;; -*- lexical-binding: t -*-
+
+;; Correct
+
+(defun faw-str-decl-code (x)
+ "something"
+ (declare (pure t))
+ (print x))
+
+(defun faw-doc-decl-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ (print x))
+
+(defun faw-str-int-code (x)
+ "something"
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-int-code (x)
+ (:documentation "something")
+ (interactive "P")
+ (print x))
+
+(defun faw-decl-int-code (x)
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+(defun faw-str-decl-int-code (x)
+ "something"
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-decl-int-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+
+;; Correct (last string is return value)
+
+(defun faw-str ()
+ "something")
+
+(defun faw-decl-str ()
+ (declare (pure t))
+ "something")
+
+(defun faw-decl-int-str ()
+ (declare (pure t))
+ (interactive)
+ "something")
+
+(defun faw-str-str ()
+ "something"
+ "something else")
+
+(defun faw-doc-str ()
+ (:documentation "something")
+ "something else")
+
+
+;; Incorrect (bad order)
+
+(defun faw-int-decl-code (x)
+ (interactive "P")
+ (declare (pure t))
+ (print x))
+
+(defun faw-int-str-code (x)
+ (interactive "P")
+ "something"
+ (print x))
+
+(defun faw-int-doc-code (x)
+ (interactive "P")
+ (:documentation "something")
+ (print x))
+
+(defun faw-decl-str-code (x)
+ (declare (pure t))
+ "something"
+ (print x))
+
+(defun faw-decl-doc-code (x)
+ (declare (pure t))
+ (:documentation "something")
+ (print x))
+
+(defun faw-str-int-decl-code (x)
+ "something"
+ (interactive "P")
+ (declare (pure t))
+ (print x))
+
+(defun faw-doc-int-decl-code (x)
+ (:documentation "something")
+ (interactive "P")
+ (declare (pure t))
+ (print x))
+
+(defun faw-int-str-decl-code (x)
+ (interactive "P")
+ "something"
+ (declare (pure t))
+ (print x))
+
+(defun faw-int-doc-decl-code (x)
+ (interactive "P")
+ (:documentation "something")
+ (declare (pure t))
+ (print x))
+
+(defun faw-int-decl-str-code (x)
+ (interactive "P")
+ (declare (pure t))
+ "something"
+ (print x))
+
+(defun faw-int-decl-doc-code (x)
+ (interactive "P")
+ (declare (pure t))
+ (:documentation "something")
+ (print x))
+
+(defun faw-decl-int-str-code (x)
+ (declare (pure t))
+ (interactive "P")
+ "something"
+ (print x))
+
+(defun faw-decl-int-doc-code (x)
+ (declare (pure t))
+ (interactive "P")
+ (:documentation "something")
+ (print x))
+
+(defun faw-decl-str-int-code (x)
+ (declare (pure t))
+ "something"
+ (interactive "P")
+ (print x))
+
+(defun faw-decl-doc-int-code (x)
+ (declare (pure t))
+ (:documentation "something")
+ (interactive "P")
+ (print x))
+
+
+;; Incorrect (duplication)
+
+(defun faw-str-str-decl-int-code (x)
+ "something"
+ "something else"
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+(defun faw-str-doc-decl-int-code (x)
+ "something"
+ (:documentation "something else")
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-str-decl-int-code (x)
+ (:documentation "something")
+ "something else"
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-doc-decl-int-code (x)
+ (:documentation "something")
+ (:documentation "something else")
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+(defun faw-str-decl-str-int-code (x)
+ "something"
+ (declare (pure t))
+ "something else"
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-decl-str-int-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ "something else"
+ (interactive "P")
+ (print x))
+
+(defun faw-str-decl-doc-int-code (x)
+ "something"
+ (declare (pure t))
+ (:documentation "something else")
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-decl-doc-int-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ (:documentation "something else")
+ (interactive "P")
+ (print x))
+
+(defun faw-str-decl-decl-int-code (x)
+ "something"
+ (declare (pure t))
+ (declare (indent 1))
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-decl-decl-int-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ (declare (indent 1))
+ (interactive "P")
+ (print x))
+
+(defun faw-str-decl-int-decl-code (x)
+ "something"
+ (declare (pure t))
+ (interactive "P")
+ (declare (indent 1))
+ (print x))
+
+(defun faw-doc-decl-int-decl-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ (interactive "P")
+ (declare (indent 1))
+ (print x))
+
+(defun faw-str-decl-int-int-code (x)
+ "something"
+ (declare (pure t))
+ (interactive "P")
+ (interactive "p")
+ (print x))
+
+(defun faw-doc-decl-int-int-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ (interactive "P")
+ (interactive "p")
+ (print x))
+
+(defun faw-str-int-decl-int-code (x)
+ "something"
+ (interactive "P")
+ (declare (pure t))
+ (interactive "p")
+ (print x))
+
+(defun faw-doc-int-decl-int-code (x)
+ (:documentation "something")
+ (interactive "P")
+ (declare (pure t))
+ (interactive "p")
+ (print x))
(should (equal (get fname 'lisp-indent-function) 1))
(should (equal (aref bc 4) "tata\n\n(fn X)")))))
+(ert-deftest bytecomp-fun-attr-warn ()
+ ;; Check that warnings are emitted when doc strings, `declare' and
+ ;; `interactive' forms don't come in the proper order, or more than once.
+ (let* ((filename "fun-attr-warn.el")
+ (el (ert-resource-file filename))
+ (elc (concat el "c"))
+ (text-quoting-style 'grave))
+ (with-current-buffer (get-buffer-create "*Compile-Log*")
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (byte-compile-file el)
+ (let ((expected
+ '("70:4: Warning: `declare' after `interactive'"
+ "74:4: Warning: Doc string after `interactive'"
+ "79:4: Warning: Doc string after `interactive'"
+ "84:4: Warning: Doc string after `declare'"
+ "89:4: Warning: Doc string after `declare'"
+ "96:4: Warning: `declare' after `interactive'"
+ "102:4: Warning: `declare' after `interactive'"
+ "108:4: Warning: `declare' after `interactive'"
+ "106:4: Warning: Doc string after `interactive'"
+ "114:4: Warning: `declare' after `interactive'"
+ "112:4: Warning: Doc string after `interactive'"
+ "118:4: Warning: Doc string after `interactive'"
+ "119:4: Warning: `declare' after `interactive'"
+ "124:4: Warning: Doc string after `interactive'"
+ "125:4: Warning: `declare' after `interactive'"
+ "130:4: Warning: Doc string after `declare'"
+ "136:4: Warning: Doc string after `declare'"
+ "142:4: Warning: Doc string after `declare'"
+ "148:4: Warning: Doc string after `declare'"
+ "159:4: Warning: More than one doc string"
+ "165:4: Warning: More than one doc string"
+ "171:4: Warning: More than one doc string"
+ "178:4: Warning: More than one doc string"
+ "186:4: Warning: More than one doc string"
+ "192:4: Warning: More than one doc string"
+ "200:4: Warning: More than one doc string"
+ "206:4: Warning: More than one doc string"
+ "215:4: Warning: More than one `declare' form"
+ "222:4: Warning: More than one `declare' form"
+ "230:4: Warning: More than one `declare' form"
+ "237:4: Warning: More than one `declare' form"
+ "244:4: Warning: More than one `interactive' form"
+ "251:4: Warning: More than one `interactive' form"
+ "258:4: Warning: More than one `interactive' form"
+ "257:4: Warning: `declare' after `interactive'"
+ "265:4: Warning: More than one `interactive' form"
+ "264:4: Warning: `declare' after `interactive'")))
+ (goto-char (point-min))
+ (let ((actual nil))
+ (while (re-search-forward
+ (rx bol (* (not ":")) ":"
+ (group (+ digit) ":" (+ digit) ": Warning: "
+ (or "More than one " (+ nonl) " form"
+ (: (+ nonl) " after " (+ nonl))))
+ eol)
+ nil t)
+ (push (match-string 1) actual))
+ (setq actual (nreverse actual))
+ (should (equal actual expected)))))))
+
+
;; Local Variables:
;; no-byte-compile: t
;; End:
projects / emacs.git / commitdiff