[elpa] externals/relint d4a6d46 37/44: Evaluate some more functions, macros and special forms

[Mattias Engdegård]

branch: externals/relint
commit d4a6d46e6cbf8510a11ff59aa0a58a62bbb2e0d5
Author: Mattias Engdegård <address@hidden>
Commit: Mattias Engdegård <address@hidden>

    Evaluate some more functions, macros and special forms
    
    Including sort, pcase and cond.
---
 relint.el | 68 +++++++++++++++++++++++++++++++++++++++++++++++----------------
 1 file changed, 51 insertions(+), 17 deletions(-)

diff --git a/relint.el b/relint.el
index 8ef0e4b..7e85bb3 100644
--- a/relint.el
+++ b/relint.el
@@ -195,7 +195,8 @@
     symbol-name
     null not
     eq eql equal
-    string-equal string= string< string-lessp char-equal string-match-p
+    string-equal string= string< string-lessp string> string-greaterp
+    char-equal string-match-p
     string-match split-string replace-regexp-in-string
     wildcard-to-regexp
     combine-and-quote-strings split-string-and-unquote
@@ -206,12 +207,13 @@
     vector aref elt vconcat
     char-to-string string-to-char
     number-to-string string-to-number int-to-string
+    string-to-list string-to-vector string-or-null-p
     upcase downcase capitalize
     purecopy copy-sequence copy-alist copy-tree
     assoc-default member-ignore-case alist-get
     last butlast number-sequence
     plist-get plist-member
-    consp atom stringp symbolp listp nlistp
+    consp atom stringp symbolp listp nlistp booleanp
     integerp numberp natnump fixnump bignump characterp zerop
     sequencep vectorp arrayp
     + - * / % mod 1+ 1- max min < <= = > >= /= abs))
@@ -355,7 +357,6 @@
             (apply (car form) args)
           (error (throw 'relint-eval 'no-value))))))
 
-   ;; if: evaluate condition and the right branch.
    ((eq (car form) 'if)
     (let ((condition (relint--eval (cadr form))))
       (let ((then-part (nth 2 form))
@@ -363,11 +364,11 @@
         (cond (condition
                (relint--eval then-part))
               ((and else-tail (cdr else-tail))
-               (throw 'relint-eval 'no-value)) ; Ignore multi-value else bodies
+               ;; Ignore multi-expression else bodies
+               (throw 'relint-eval 'no-value))
               (else-tail
                (relint--eval (car else-tail)))))))
 
-   ;; and: keep evaluating until false or empty.
    ((eq (car form) 'and)
     (if (cdr form)
         (let ((val (relint--eval (cadr form))))
@@ -376,7 +377,6 @@
             val))
       t))
 
-   ;; or: keep evaluating until true or empty.
    ((eq (car form) 'or)
     (if (cdr form)
         (let ((val (relint--eval (cadr form))))
@@ -385,9 +385,23 @@
             val))
       nil))
    
-   ;; FIXME: cond
+   ((eq (car form) 'cond)
+    (and (cdr form)
+         (let ((clause (cadr form)))
+           (if (consp clause)
+               (let ((val (relint--eval (car clause))))
+                 (if val
+                     (if (cdr clause)
+                         (if (= (length (cdr clause)) 1)
+                             (relint--eval (cadr clause))
+                           ;; Ignore multi-expression clauses
+                           (throw 'relint-eval 'no-value))
+                       val)
+                   (relint--eval (cons 'cond (cddr form)))))
+             ;; Syntax error
+             (throw 'relint-eval 'no-value)))))
 
-   ((eq (car form) 'progn)
+   ((memq (car form) '(progn ignore-errors))
     (cond ((null (cdr form)) nil)
           ((null (cddr form)) (relint--eval (cadr form)))
           (t (throw 'relint-eval 'no-value))))
@@ -401,9 +415,9 @@
     (let ((arg (relint--eval (cadr form))))
       (delete-dups (copy-sequence arg))))
 
-   ;; FIXME: more macros: pcase, pcase-let...
-   ;; Maybe ones from cl?
-   ((memq (car form) '(when unless \` backquote-list*))
+   ;; FIXME: more macros. Maybe ones from cl?
+   ;; If they are useful but expand to impure code, we need to emulate them.
+   ((memq (car form) '(when unless \` backquote-list* pcase pcase-let))
     (relint--eval (macroexpand form)))
 
    ;; apply: Call only if the function is safe and all args evaluated.
@@ -431,7 +445,7 @@
     (let* ((fun (relint--wrap-function (relint--eval (cadr form))))
            (arg (relint--eval-list (caddr form)))
            (seq (if (listp arg)
-                    (delq nil arg)
+                    (remq nil arg)
                   arg)))
       (condition-case err
           (funcall (car form) fun seq)
@@ -447,7 +461,17 @@
         (error (signal 'relint--eval-error (format "eval error: %S: %s"
                                                    form err))))))
           
-   ;; FIXME: sort
+   ;; sort: accept missing items in a list argument.
+   ((eq (car form) 'sort)
+    (let* ((arg (relint--eval-list (cadr form)))
+           (seq (cond ((listp arg) (remq nil arg))
+                      ((sequencep arg) (copy-sequence arg))
+                      (arg)))
+           (pred (relint--wrap-function (relint--eval (caddr form)))))
+      (condition-case err
+          (sort seq pred)
+        (error (signal 'relint--eval-error (format "eval error: %S: %s"
+                                                   form err))))))
 
    ;; rx, rx-to-string: check for (eval ...) constructs first, then apply.
    ((eq (car form) 'rx)
@@ -463,8 +487,9 @@
 
    ;; 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)))
+   ((eq (car form) 'let)
+    (unless (= (length form) 3)
+      (throw 'relint-eval 'no-value))
     (let ((bindings
            (mapcar (lambda (binding)
                      (if (consp binding)
@@ -476,8 +501,9 @@
         (relint--eval (car (last form))))))
 
    ;; let*: bind a single variable and recurse.
-   ((and (eq (car form) 'let*)
-         (null (cdddr form)))
+   ((eq (car form) 'let*)
+    (unless (= (length form) 3)
+      (throw 'relint-eval 'no-value))
     (let ((bindings (cadr form)))
       (if bindings
           (let* ((binding (car bindings))
@@ -496,6 +522,14 @@
    ((eq (car form) '\,)
     (relint--eval (cadr form)))
 
+   ;; featurep: only handle features that we are reasonably sure about,
+   ;; to avoid depending too much on the particular host Emacs.
+   ((eq (car form) 'featurep)
+    (let ((arg (relint--eval (cadr form))))
+      (cond ((eq arg 'xemacs) nil)
+            ((memq arg '(emacs mule)) t)
+            (t (throw 'relint-eval 'no-value)))))
+
    (t
     ;;(relint--add-to-error-buffer (format "eval rule missing: %S\n" form))
     (throw 'relint-eval 'no-value))))