[elpa] externals/relint 6212b6f 22/23: Evaluate more functions and macros

[Mattias Engdegård]

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

    Evaluate more functions and macros
    
    cl-loop, catch, condition-case, cl-flet, cl-flet*, cl-labels,
    cl-assert, cl-case, mapc, cXXXr, assoc-string, intern, intern-soft,
    make-symbol, compare-strings, flatten-tree.
    
    (`catch' and `condition-case' don't actually catch any throws or errors.)
---
 relint.el       | 33 ++++++++++++++++++++++++++++-----
 test/3.elisp    | 34 ++++++++++++++++++++++++++++++++++
 test/3.expected | 12 ++++++++++++
 test/4.elisp    |  3 ++-
 test/4.expected |  9 ++++++---
 test/7.elisp    | 16 ++++++++++++++++
 test/7.expected | 12 ++++++++++++
 test/8.elisp    | 16 ++++++++++++++++
 test/8.expected |  9 +++++++++
 9 files changed, 135 insertions(+), 9 deletions(-)

diff --git a/relint.el b/relint.el
index c2113be..03b3a3b 100644
--- a/relint.el
+++ b/relint.el
@@ -335,19 +335,22 @@ or (NAME val VAL), for values.")
   '(cons list append
     concat
     car cdr caar cadr cdar cddr car-safe cdr-safe nth nthcdr
+    caaar cdaar cadar cddar caadr cdadr caddr cdddr
     format format-message
     regexp-quote regexp-opt regexp-opt-charset
     reverse
     member memq memql remove remq member-ignore-case
-    assoc assq rassoc rassq
+    assoc assq rassoc rassq assoc-string
     identity
     string make-string make-list
     substring
     length safe-length
     symbol-name
+    intern intern-soft make-symbol
     null not xor
     eq eql equal
     string-equal string= string< string-lessp string> string-greaterp
+    compare-strings
     char-equal string-match-p
     string-match split-string
     wildcard-to-regexp
@@ -362,6 +365,7 @@ or (NAME val VAL), for values.")
     string-to-list string-to-vector string-or-null-p
     upcase downcase capitalize
     purecopy copy-sequence copy-alist copy-tree
+    flatten-tree
     member-ignore-case
     last butlast number-sequence
     plist-get plist-member
@@ -544,7 +548,8 @@ not be evaluated safely."
                  (eq (caar body) '\,))     ; In case we are inside a backquote.
             (throw 'relint-eval 'no-value)
           (car body)))
-       ((eq head 'function)
+       ((memq head '(function cl-function))
+        ;; Treat cl-function like plain function (close enough).
         (car body))
        ((eq head 'lambda)
         form)
@@ -624,6 +629,11 @@ not be evaluated safely."
        ((memq head '(progn ignore-errors eval-when-compile eval-and-compile))
         (relint--eval-body body))
 
+       ;; Hand-written implementation of `cl-assert' -- good enough.
+       ((eq head 'cl-assert)
+        (unless (relint--eval (car body))
+          (throw 'relint-eval 'no-value)))
+
        ((eq head 'prog1)
         (let ((val (relint--eval (car body))))
           (relint--eval-body (cdr body))
@@ -643,9 +653,22 @@ not be evaluated safely."
        ;; Safe macros that expand to pure code, and their auxiliary macros.
        ((memq head '(when unless
                      \` backquote-list*
-                     pcase pcase-let pcase-let* pcase--flip))
+                     pcase pcase-let pcase-let* pcase--flip
+                     cl-case cl-loop cl-flet cl-flet* cl-labels))
         (relint--eval (macroexpand form)))
 
+       ;; catch: as long as nobody throws, this naïve code is fine.
+       ((eq head 'catch)
+        (relint--eval-body (cdr body)))
+
+       ;; condition-case: as long as there is no error...
+       ((eq head 'condition-case)
+        (relint--eval (cadr body)))
+
+       ;; cl--block-wrapper: works like identity, more or less.
+       ((eq head 'cl--block-wrapper)
+        (relint--eval (car body)))
+
        ;; Functions taking a function as first argument.
        ((memq head '(apply funcall mapconcat
                      cl-some cl-every cl-notany cl-notevery))
@@ -684,8 +707,8 @@ not be evaluated safely."
               (apply head fun args)
             (error (throw 'relint-eval 'no-value)))))
 
-       ;; mapcar, mapcan: accept missing items in the list argument.
-       ((memq head '(mapcar mapcan))
+       ;; mapcar, mapcan, mapc: accept missing items in the list argument.
+       ((memq head '(mapcar mapcan mapc))
         (let* ((fun (relint--wrap-function (relint--eval (car body))))
                (arg (relint--eval-list (cadr body)))
                (seq (if (listp arg)
diff --git a/test/3.elisp b/test/3.elisp
index 64763a2..dfe8599 100644
--- a/test/3.elisp
+++ b/test/3.elisp
@@ -135,3 +135,37 @@
    (copy-sequence (remove my-unknown (list my-unknown "[55]")))
    (copy-alist (remq my-unknown (list my-unknown "[66]")))
    (delete-dups (list my-unknown "[77]" my-unknown "[77]"))))
+
+(defun test-eval-cxxxr ()
+  (looking-at
+   (concat "+"                          ; "+abcdefgh"
+           (mapconcat
+            #'symbol-name
+            (list
+             (caaar '(((a . b) . (c . d)) . ((e . f) . (g . h))))
+             (cdaar '(((a . b) . (c . d)) . ((e . f) . (g . h))))
+             (cadar '(((a . b) . (c . d)) . ((e . f) . (g . h))))
+             (cddar '(((a . b) . (c . d)) . ((e . f) . (g . h))))
+             (caadr '(((a . b) . (c . d)) . ((e . f) . (g . h))))
+             (cdadr '(((a . b) . (c . d)) . ((e . f) . (g . h))))
+             (caddr '(((a . b) . (c . d)) . ((e . f) . (g . h))))
+             (cdddr '(((a . b) . (c . d)) . ((e . f) . (g . h)))))
+            ""))))
+
+(defun test-eval-intern ()
+  (looking-at
+   (concat "?"                          ; "?abc"
+           (symbol-name (intern "a"))
+           (symbol-name (intern-soft "b"))
+           (symbol-name (make-symbol "c")))))
+
+(defun test-eval-compare-strings ()
+  (looking-at
+   (progn                               ; "[AA]"
+     (cl-assert 'haha)
+     (and (compare-strings "abc" 0 2 "ABC" 0 2 t)
+          "[AA]"))))
+
+(defun test-eval-flatten-tree ()
+  (looking-at
+   (apply #'concat (flatten-tree '("$" ((("a") "b") ("c")))))))   ; "$abc"
diff --git a/test/3.expected b/test/3.expected
index 9e14570..bee21d2 100644
--- a/test/3.expected
+++ b/test/3.expected
@@ -34,3 +34,15 @@
 3.elisp:130:3: In another-bad-regexp-list: Duplicated `7' inside character 
alternative (pos 2)
   "[77]"
    ..^
+3.elisp:141:4: In call to looking-at: Unescaped literal `+' (pos 0)
+  "+abcdefgh"
+   ^
+3.elisp:157:4: In call to looking-at: Unescaped literal `?' (pos 0)
+  "?abc"
+   ^
+3.elisp:164:4: In call to looking-at: Duplicated `A' inside character 
alternative (pos 2)
+  "[AA]"
+   ..^
+3.elisp:171:4: In call to looking-at: Unescaped literal `$' (pos 0)
+  "$abc"
+   ^
diff --git a/test/4.elisp b/test/4.elisp
index b9ae44a..9213b8c 100644
--- a/test/4.elisp
+++ b/test/4.elisp
@@ -44,7 +44,8 @@
   (looking-at (when t "b++"))
   (looking-at (unless nil "c++"))
   (looking-at (string-join `("a" ,@(list "$") ,"b")))
-  (looking-at (pcase 'a ((pred symbolp) "d++"))))
+  (looking-at (pcase 'a ((pred symbolp) "d++")))
+  (looking-at (cl-case 'z (b "m") (z "*"))))
 
 ;; Test repeated use of global variable
 (defconst my-var-a "*")
diff --git a/test/4.expected b/test/4.expected
index d1897ed..8a6c403 100644
--- a/test/4.expected
+++ b/test/4.expected
@@ -49,12 +49,15 @@
 4.elisp:47:15: In call to looking-at: Repetition of repetition (pos 2)
   "d++"
    ..^
-4.elisp:54:15: In call to looking-at: Unescaped literal `*' (pos 0)
-  "*b"
+4.elisp:48:15: In call to looking-at: Unescaped literal `*' (pos 0)
+  "*"
    ^
 4.elisp:55:15: In call to looking-at: Unescaped literal `*' (pos 0)
+  "*b"
+   ^
+4.elisp:56:15: In call to looking-at: Unescaped literal `*' (pos 0)
   "*bc"
    ^
-4.elisp:61:15: In call to looking-at: Unescaped literal `*' (pos 0)
+4.elisp:62:15: In call to looking-at: Unescaped literal `*' (pos 0)
   "*a"
    ^
diff --git a/test/7.elisp b/test/7.elisp
index b0ed01c..e49b08a 100644
--- a/test/7.elisp
+++ b/test/7.elisp
@@ -19,3 +19,19 @@
 
 (defun test-while ()
   (looking-at (my-while-fun)))
+
+(defun test-mapc ()
+  (looking-at (let ((s ""))             ; "[**]"
+                (mapc (lambda (x) (setq s (concat s x)))
+                      '("[" "*" "*" "]"))
+                s)))
+
+(defun test-eval-cl-loop ()
+  (looking-at                           ; "!\"#$%"
+   (apply 'string (cl-loop for i in (number-sequence ?! ?%) collect i))))
+
+(defun test-catch ()
+  (looking-at (catch 'boing "[XX]")))
+
+(defun test-condition-case ()
+  (looking-at (condition-case err "[XX]" (error "Y"))))
diff --git a/test/7.expected b/test/7.expected
index 5275a63..994ef63 100644
--- a/test/7.expected
+++ b/test/7.expected
@@ -4,3 +4,15 @@
 7.elisp:21:15: In call to looking-at: Unescaped literal `$' (pos 3)
   "!\"#$%"
    ....^
+7.elisp:24:15: In call to looking-at: Duplicated `*' inside character 
alternative (pos 2)
+  "[**]"
+   ..^
+7.elisp:31:4: In call to looking-at: Unescaped literal `$' (pos 3)
+  "!\"#$%"
+   ....^
+7.elisp:34:15: In call to looking-at: Duplicated `X' inside character 
alternative (pos 2)
+  "[XX]"
+   ..^
+7.elisp:37:15: In call to looking-at: Duplicated `X' inside character 
alternative (pos 2)
+  "[XX]"
+   ..^
diff --git a/test/8.elisp b/test/8.elisp
new file mode 100644
index 0000000..f55fbf8
--- /dev/null
+++ b/test/8.elisp
@@ -0,0 +1,16 @@
+;;; Relint test file 8          -*- emacs-lisp -*-
+
+(defun test-cl-flet ()
+  (looking-at
+   (cl-flet ((f (x) (concat "+" x)))    ; "+A"
+     (f "A"))))
+
+(defun test-cl-flet* ()
+  (looking-at
+   (cl-flet* ((f (x) (concat "+" x)))   ; "+B"
+     (f "B"))))
+
+(defun test-cl-labels ()
+  (looking-at
+   (cl-labels ((f (x) (concat "*" x)))  ; "*C"
+     (f "C"))))
diff --git a/test/8.expected b/test/8.expected
new file mode 100644
index 0000000..8ae9a90
--- /dev/null
+++ b/test/8.expected
@@ -0,0 +1,9 @@
+8.elisp:5:4: In call to looking-at: Unescaped literal `+' (pos 0)
+  "+A"
+   ^
+8.elisp:10:4: In call to looking-at: Unescaped literal `+' (pos 0)
+  "+B"
+   ^
+8.elisp:15:4: In call to looking-at: Unescaped literal `*' (pos 0)
+  "*C"
+   ^