Coverage report: /home/runner/work/geb/geb/src/extensions/sub-expressions.lisp

KindCoveredAll%
expression96112 85.7
branch2130 70.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb.extensions)
2
 
3
 (deftype obj-morph () `(or cat-obj cat-morph t))
4
 
5
 (-> can-continuep (t) boolean)
6
 (defun can-continuep (term)
7
   (and (or (typep term 'pointwise-mixin)
8
            (typep term 'list))
9
        (not (typep term 'cat-obj))
10
        (not (typep term 'number))
11
        (not (typep term 'string))
12
        (not (typep term 'geb.vampir.spec:constant))))
13
 
14
 (-> common-sub-expressions (obj-morph) (values obj-morph fset:map))
15
 (defun common-sub-expressions (term)
16
   "Compute common sub-expressions and return an object with the
17
 appropriate sub-expressions uniquely identified"
18
   (if (can-continuep term)
19
       (keep-unique term (compute-common-usages term))
20
       (values term (fset:empty-map))))
21
 
22
 (-> compute-common-usages (obj-morph) fset:bag)
23
 (defun compute-common-usages (obj)
24
   ;; we are going to be smart about this
25
   ;; no manual recursion, we don't need that
26
   (labels ((reduce-fn (bag term)
27
              (cond ((not (can-continuep term))
28
                     bag)
29
                    ;; we don't want to actually add
30
                    ;; to a total that is already
31
                    ;; count
32
                    ((fset:member? term bag)
33
                     (fset:with bag term))
34
                    (t
35
                     (recursive (fset:with bag term) term))))
36
            (recursive (bag term)
37
              (if (listp term)
38
                  (reduce #'reduce-fn term :initial-value bag)
39
                  (reduce-pointwise #'reduce-fn term bag))))
40
     (values
41
      (fset:filter-pairs (lambda (x y) (declare (ignore x)) (<= 2 y))
42
                         (recursive (fset:empty-bag) obj)))))
43
 
44
 (-> keep-unique (obj-morph fset:bag) (values obj-morph fset:map))
45
 (defun keep-unique (obj bag)
46
   "given a BAG and an term, mark each term which appears in the bag as a
47
 [COMMON-SUB-EXPRESSION][type].
48
 
49
 We also return the map of names that each common expression is had,
50
 for further processing.
51
 
52
 This is part two of the COMMON-SUB-EXPRESSIONS pass."
53
   (let ((mapping (fset:image (lambda (x y)
54
                                (declare (ignore y))
55
                                (values x (gensym)))
56
                              (fset:convert 'fset:map bag))))
57
     (labels ((recursive (obj)
58
                (if (not (can-continuep obj))
59
                    (values obj mapping)
60
                    (let ((looked  (fset:lookup mapping obj))
61
                          (new-obj
62
                            (if (listp obj)
63
                                (mapcar #'recursive obj)
64
                                (map-pointwise #'recursive obj))))
65
                      (if looked
66
                          (make-common-sub-expression :obj new-obj :name looked)
67
                          new-obj)))))
68
       (values (recursive obj) mapping))))