[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/relint 019f4cf 10/44: Rewrite the partial evaluator and
From: |
Mattias Engdegård |
Subject: |
[elpa] externals/relint 019f4cf 10/44: Rewrite the partial evaluator and extend coverage |
Date: |
Tue, 26 Mar 2019 12:57:25 -0400 (EDT) |
branch: externals/relint
commit 019f4cf6c6ca4776a32af7bf0fe121080f656ff5
Author: Mattias Engdegård <address@hidden>
Commit: Mattias Engdegård <address@hidden>
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)
- [elpa] branch externals/relint created (now ee70350), Mattias Engdegård, 2019/03/26
- [elpa] externals/relint 0604fad 43/44: Use a custom mode for the *relint* buffer, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint ee70350 44/44: FSF copyright, URL, and increment version to 1.5, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint 0fd1d46 29/44: Rename trawl to relint, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint e882b71 42/44: Detect regexps spliced into [...], Mattias Engdegård, 2019/03/26
- [elpa] externals/relint c1b92cc 36/44: Wrap and evaluate defined functions passed as parameters, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint d4a6d46 37/44: Evaluate some more functions, macros and special forms, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint 019f4cf 10/44: Rewrite the partial evaluator and extend coverage,
Mattias Engdegård <=
- [elpa] externals/relint 365dc91 41/44: Check bad skip-set provenance, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint a1829d7 39/44: Refactor the file scanning and linting code, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint 0f76132 40/44: Add README.org, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint e824db0 38/44: Expand locally defined macros, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint c215d54 34/44: More careful evaluation of if, when, unless, and, or, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint 15c799e 35/44: Evaluate calls to functions defined in the same file., Mattias Engdegård, 2019/03/26
- [elpa] externals/relint 2d1f488 32/44: mapcar on non-list sequence, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint af745bb 30/44: Update the package description. Increment version to 1.4, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint e1b1ef9 22/44: Run in two phases on each file, Mattias Engdegård, 2019/03/26
- [elpa] externals/relint 7a1b632 33/44: Add wildcard-to-regexp as 'pure' function, Mattias Engdegård, 2019/03/26