branch: externals/relint commit 019f4cf6c6ca4776a32af7bf0fe121080f656ff5 Author: Mattias Engdegård <matti...@acm.org> Commit: Mattias Engdegård <matti...@acm.org>
Rewrite the partial evaluator and extend coverage Complete rewrite making the partial evaluator slightly less ad-hoc, evaluate more complex expressions, and extend coverage to more functions and variables. --- trawl.el | 368 ++++++++++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 295 insertions(+), 73 deletions(-) diff --git a/trawl.el b/trawl.el index 7067155..3193f26 100644 --- a/trawl.el +++ b/trawl.el @@ -141,105 +141,310 @@ complaints))) ;; Alist of variable definitions seen so far. +;; The variable names map to unevaluated forms. (defvar trawl--variables) ;; List of variables that have been checked, so that we can avoid ;; checking direct uses of it. (defvar trawl--checked-variables) -(defun trawl--remove-comma (form) +;; Whether form is a safe expression to evaluate. +(defun trawl--safe-expr (form) (cond - ((not (consp form)) form) - ((eq (car form) '\,) (trawl--remove-comma (cadr form))) + ((symbolp form) + (or (memq form '(t nil)) + (assq form trawl--variables))) + ((consp form) + (or (eq (car form) 'quote) + (and (trawl--safe-function (car form)) + (not (memq nil (mapcar #'trawl--safe-expr (cdr form))))))) + (t t))) ; Other atoms assumed OK. + +;; Whether f is safe to pass as a higher-order function in a call. +(defun trawl--safe-function (f) + (when (and (consp f) (memq (car f) '(quote function))) + (setq f (cadr f))) + (cond + ;; Functions (and some special forms/macros) considered safe. + ((symbolp f) + (or (get f 'side-effect-free) + (memq f '(caar cadr cdar cddr purecopy remove remq + if unless when and or + regexp-opt regexp-opt-charset)))) + + ;; Only permit one-argument one-expression lambdas (for purity), + ;; where the body only refers to arguments and known variables, + ;; and calls safe functions. + ((and (consp f) (eq (car f) 'lambda)) + (let ((vars (cadr f)) + (body (cddr f))) + (and (= (length vars) 1) + (= (length body) 1) + (let ((trawl--variables + (cons (cons (car vars) nil) trawl--variables))) + (trawl--safe-expr (car body)))))))) + +;; Whether an `rx' form is safe to translate. +(defun trawl--rx-safe (form) + (cond + ((atom form) t) + ((eq (car form) 'eval) + (let ((arg (trawl--eval (cadr form)))) + (and (stringp arg) + (setcar (cdr form) arg)))) ; Avoid double work. + ;; Avoid traversing impure lists like (?A . ?Z). + ((memq (car form) '(any in char not-char)) t) + (t (not (memq nil (mapcar #'trawl--rx-safe (cdr form))))))) + +;; Evaluate a form as far as possible. Substructures that cannot be evaluated +;; become `no-value'. +(defun trawl--eval (form) + (cond + ((symbolp form) + (and form + (let ((binding (assq form trawl--variables))) + (if binding + (trawl--eval (cdr binding)) + 'no-value)))) + ((atom form) + form) + ((not (symbolp (car form))) + (trawl--add-to-error-buffer (format "eval error: %S" form)) + 'no-value) + ((eq (car form) 'quote) + (cadr form)) + ((eq (car form) 'eval-when-compile) + (trawl--eval (car (last form)))) + ((eq (car form) 'lambda) + form) + + ;; Reasonably pure functions: only call if all args can be fully evaluated. + ((or (get (car form) 'side-effect-free) + ;; Common functions that aren't marked as side-effect-free. + (memq (car form) '(caar cadr cdar cddr + regexp-opt regexp-opt-charset + decode-coding-string + format-message format-spec + purecopy remove remq + ;; We don't mind them changing the match state. + string-match string-match-p))) + (let ((args (mapcar #'trawl--eval (cdr form)))) + (if (memq 'no-value args) + 'no-value + ;; Catching all errors isn't wonderful, but sometimes a global + ;; variable argument has an unsuitable default value which is supposed + ;; to have been changed at the expression point. + (condition-case nil + (apply (car form) args) + (error 'no-value))))) + + ;; replace-regexp-in-string: Only safe if no function given. + ((eq (car form) 'replace-regexp-in-string) + (let ((args (mapcar #'trawl--eval (cdr form)))) + (if (and (not (memq 'no-value args)) + (stringp (cadr args))) + (condition-case nil + (apply (car form) args) + (error 'no-value)) + 'no-value))) + + ;; if, when, unless, and, or: Treat these as functions and eval all args. + ((memq (car form) '(if when unless and or)) + (let ((args (mapcar #'trawl--eval (cdr form)))) + (if (memq 'no-value args) + 'no-value + ;; eval is safe here: all args are quoted constants. + (eval (cons (car form) + (mapcar (lambda (x) (list 'quote x)) args)))))) + + ((memq (car form) '(\` backquote-list*)) + (trawl--eval (macroexpand form))) + + ;; apply: Call only if the function is safe and all args evaluated. + ((eq (car form) 'apply) + (let ((fun (cadr form))) + (if (trawl--safe-function fun) + (let ((args (mapcar #'trawl--eval (cddr form)))) + (if (memq 'no-value args) + 'no-value + (condition-case nil + (apply fun args) + (error 'no-value)))) +; (trawl--add-to-error-buffer (format "%s unsafe hof: %S\n" +; (car form) fun)) + 'no-value))) + + ;; funcall: Call only if the function is safe and all args evaluated. + ((eq (car form) 'funcall) + (let ((args (mapcar #'trawl--eval (cdr form)))) + (if (and (not (memq 'no-value args)) + (trawl--safe-function (car args))) + (condition-case nil + (apply (car args) (cdr args)) + (error 'no-value)) +; (trawl--add-to-error-buffer (format "unsafe funcall: %S -> %S\n" +; form args)) + 'no-value))) + + ;; map*: Call only if the function is safe and all args evaluated. + ((memq (car form) '(mapcar mapconcat mapcan)) + (let ((fun (cadr form))) + (if (trawl--safe-function fun) + (let ((args (mapcar #'trawl--eval (cddr form)))) + (if (memq 'no-value args) + 'no-value + (condition-case nil + (apply (car form) fun args) + (error 'no-value)))) +; (trawl--add-to-error-buffer (format "%s unsafe hof: %S\n" +; (car form) fun)) + 'no-value))) + + ;; rx, rx-to-string: check for (eval ...) constructs first, then apply. + ((eq (car form) 'rx) + (if (trawl--rx-safe (cdr form)) + (trawl--eval (macroexpand form)) + 'no-value)) + + ((eq (car form) 'rx-to-string) + (if (trawl--rx-safe (cdr form)) + (let ((arg (trawl--eval (cadr form)))) + (if (eq arg 'no-value) + 'no-value + (apply 'rx-to-string (list arg)))) + 'no-value)) + + ;; setq: Ignore its side-effect and just pass on the value. + ((eq (car form) 'setq) + (let ((val (trawl--eval (caddr form)))) + (if (eq val 'no-value) + 'no-value + val))) + + ;; let and let*: do not permit multi-expression bodies, since they + ;; will contain necessary side-effects that we don't handle. + ((and (eq (car form) 'let) + (null (cdddr form))) + (let ((bindings + (mapcar (lambda (binding) + (if (consp binding) + (cons (car binding) + (list 'quote (trawl--eval (cadr binding)))) + (cons binding nil))) + (cadr form)))) + (let ((trawl--variables (append bindings trawl--variables))) + (trawl--eval (car (last form)))))) + + ;; let*: bind a single variable and recurse. + ((and (eq (car form) 'let*) + (null (cdddr form))) + (let ((bindings (cadr form))) + (if bindings + (let* ((binding (car bindings)) + (trawl--variables + (cons + (if (consp binding) + (cons (car binding) + (list 'quote (trawl--eval (cadr binding)))) + (cons binding nil)) + trawl--variables))) + (trawl--eval `(let* ,(cdr bindings) ,@(cddr form)))) + (trawl--eval (car (last form)))))) + + ;; Loose comma: can occur if we unwittingly stumbled into a backquote + ;; form. Just eval the arg and hope for the best. + ((eq (car form) '\,) + (trawl--eval (cadr form))) + + ((memq (car form) '(cond)) 'no-value) + (t - (cons (trawl--remove-comma (car form)) - (trawl--remove-comma (cdr form)))))) +; (trawl--add-to-error-buffer (format "eval rule missing: %S\n" form)) + 'no-value))) -;; Return a value peeled of irrelevancies. -(defun trawl--peel (form) +;; Evaluate a form as far as possible, attempting to keep its list structure +;; even if all subexpressions cannot be evaluated. Parts that cannot be +;; evaluated are nil. +(defun trawl--eval-list (form) (cond - ((and form (symbolp form)) - (let ((val (cdr (assq form trawl--variables)))) - (and val (trawl--peel val)))) - ((not (consp form)) form) - ((eq (car form) 'list) - (trawl--peel (cdr form))) - ((memq (car form) '(quote purecopy)) - (trawl--peel (cadr form))) + ((symbolp form) + (and form + (let ((val (cdr (assq form trawl--variables)))) + (and val (trawl--eval-list val))))) + ((atom form) + form) + ((not (symbolp (car form))) + (trawl--add-to-error-buffer (format "eval error: %S\n" form)) + nil) ((eq (car form) 'eval-when-compile) - (trawl--peel (car (last form)))) - ((eq (car form) '\`) - (trawl--peel (trawl--remove-comma (cadr form)))) - (t form))) - -;; A list peeled of irrelevancies, or nil. -(defun trawl--peel-list (form) - (let ((peeled (trawl--peel form))) - (and (consp peeled) peeled))) - -;; Convert something to a list of strings, or nil. -(defun trawl--get-string-list (form) - (let ((parts (mapcar #'trawl--get-string (trawl--peel-list form)))) - (if (memq nil parts) - nil - parts))) + (trawl--eval-list (car (last form)))) + + ;; Pure structure-generating functions: Apply even if we cannot evaluate + ;; all arguments (they will be nil), because we want a reasonable + ;; approximation of the structure. + ((memq (car form) '(list append cons)) + (apply (car form) (mapcar #'trawl--eval-list (cdr form)))) + + ((eq (car form) 'purecopy) + (trawl--eval-list (cadr form))) + + ((memq (car form) '(\` backquote-list*)) + (trawl--eval-list (macroexpand form))) + + (t + (let ((val (trawl--eval form))) + (if (eq val 'no-value) nil val))))) + +;; Convert something to a list, or nil. +(defun trawl--get-list (form) + (let ((val (trawl--eval-list form))) + (and (consp val) val))) ;; Convert something to a string, or nil. (defun trawl--get-string (form) - (setq form (trawl--peel form)) - (cond - ((stringp form) form) - ((not (consp form)) nil) - ((eq (car form) 'concat) - (let ((parts (trawl--get-string-list (cdr form)))) - (and parts (apply #'concat parts)))) - ((eq (car form) 'regexp-opt) - (let ((arg (trawl--get-string-list (cadr form)))) - (and arg (regexp-opt arg)))) - ((eq (car form) 'regexp-quote) - (let ((arg (trawl--get-string (cadr form)))) - (and arg (regexp-quote arg)))))) + (let ((val (trawl--eval form))) + (and (stringp val) val))) (defun trawl--check-re (form name file pos path) (let ((re (trawl--get-string form))) (when re (trawl--check-re-string re name file pos path)))) +;; Check a list of regexps. (defun trawl--check-list (form name file pos path) - (mapc (lambda (elem) (trawl--check-re-string elem name file pos path)) - (trawl--get-string-list form))) - -(defun trawl--check-list-car (form name file pos path) + ;; Don't use mapc -- mustn't crash on improper lists. + (let ((l (trawl--get-list form))) + (while (consp l) + (when (stringp (car l)) + (trawl--check-re-string (car l) name file pos path)) + (setq l (cdr l))))) + +;; Check a list of regexps or conses whose car is a regexp. +(defun trawl--check-list-any (form name file pos path) (mapc (lambda (elem) (cond - ((not (consp elem))) - ((eq (car elem) 'cons) - (trawl--check-re (cadr elem) name file pos path)) - (t - (trawl--check-re (car elem) name file pos path)))) - (trawl--peel-list form))) + ((stringp elem) + (trawl--check-re-string elem name file pos path)) + ((and (consp elem) + (stringp (car elem))) + (trawl--check-re-string (car elem) name file pos path)))) + (trawl--get-list form))) (defun trawl--check-font-lock-keywords (form name file pos path) - (mapc (lambda (elem) - (let* ((thing (trawl--peel elem)) - (str (trawl--get-string thing))) - (cond (str - (trawl--check-re-string str name file pos path)) - ((eq (car thing) 'cons) - (trawl--check-re (cadr thing) name file pos path)) - ((consp thing) - (trawl--check-re (car thing) name file pos path))))) - (trawl--peel-list form))) + (trawl--check-list-any form name file pos path)) +;; Check regexps in `compilation-error-regexp-alist-alist' (defun trawl--check-compilation-error-regexp-alist-alist (form name file pos path) (mapc (lambda (elem) - (trawl--check-re - (cadr elem) - (format "%s (%s)" name (car elem)) - file pos path)) - (trawl--peel-list form))) - + (if (cadr elem) + (trawl--check-re-string + (cadr elem) + (format "%s (%s)" name (car elem)) + file pos path))) + (trawl--get-list form))) + +;; Check a variable on `align-mode-rules-list' format (defun trawl--check-rules-list (form name file pos path) (mapc (lambda (rule) (when (and (consp rule) @@ -250,7 +455,9 @@ (when (stringp re) (trawl--check-re-string re (format "%s (%s)" name rule-name) file pos path))))) - (trawl--peel-list form))) + (trawl--get-list form))) + +;; FIXME: handle let-when-compile (defun trawl--check-form-recursively (form file pos path) (pcase form @@ -259,12 +466,21 @@ `replace-regexp-in-string `replace-regexp `query-replace-regexp `posix-looking-at `posix-search-backward `posix-search-forward - `posix-string-match) + `posix-string-match + `load-history-filename-element + `kill-matching-buffers) ,re-arg . ,_) (unless (and (symbolp re-arg) (memq re-arg trawl--checked-variables)) (trawl--check-re re-arg (format "call to %s" (car form)) file pos (cons 1 path)))) + (`(,(or `split-string `split-string-and-unquote + `directory-files-recursively) + ,_ ,re-arg . ,_) + (unless (and (symbolp re-arg) + (memq re-arg trawl--checked-variables)) + (trawl--check-re re-arg (format "call to %s" (car form)) + file pos (cons 2 path)))) (`(,(or `defvar `defconst `defcustom) ,name ,re-arg . ,rest) (when (symbolp name) @@ -291,7 +507,11 @@ ((string-match-p (rx (or "-regexp" "-re" "-regex" "-pattern") "-alist" eos) (symbol-name name)) - (trawl--check-list-car re-arg name file pos (cons 2 path)) + (trawl--check-list-any re-arg name file pos (cons 2 path)) + (push name trawl--checked-variables)) + ((string-match-p (rx "-mode-alist" eos) + (symbol-name name)) + (trawl--check-list-any re-arg name file pos (cons 2 path)) (push name trawl--checked-variables)) ((string-match-p (rx "-rules-list" eos) (symbol-name name)) @@ -341,6 +561,7 @@ (trawl--checked-variables nil)) (while keep-going (setq pos (point)) +; (trawl--report file (point) nil "reading") (let ((form nil)) (condition-case err (setq form (read (current-buffer))) @@ -367,6 +588,7 @@ (defun trawl--tree (dir) (dolist (file (directory-files-recursively dir (rx bos (not (any ".")) (* anything) ".el" eos))) +; (trawl--add-to-error-buffer (format "trawling %s\n" file)) (trawl--single-file file))) (defun trawl--init (file-or-dir dir)