Coverage report: /home/runner/work/geb/geb/src/specs/poly.lisp

KindCoveredAll%
expression1055 18.2
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package #:geb.poly.spec)
2
 
3
 (deftype poly ()
4
   `(or compose + * / - mod integer if-zero if-lt ident))
5
 
6
 (defclass <poly> (geb.mixins:direct-pointwise-mixin) ())
7
 
8
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9
 ;; Constructor Objects for Poly
10
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11
 
12
 (defclass compose (<poly>)
13
   ((mcar :initarg :mcar
14
          :accessor mcar
15
          :documentation "")
16
    (mcadr :initarg :mcadr
17
           :accessor mcadr
18
           :documentation "")))
19
 
20
 (defclass + (<poly>)
21
   ((mcar :initarg :mcar
22
          :accessor mcar
23
          :documentation "")
24
    (mcadr :initarg :mcadr
25
           :accessor mcadr
26
           :documentation "")))
27
 
28
 (defclass ident (<poly>)
29
   ()
30
   (:documentation "The Identity Element"))
31
 
32
 (defclass * (<poly>)
33
   ((mcar :initarg :mcar
34
          :accessor mcar
35
          :documentation "")
36
    (mcadr :initarg :mcadr
37
           :accessor mcadr
38
           :documentation "")))
39
 
40
 (defclass - (<poly>)
41
   ((mcar :initarg :mcar
42
          :accessor mcar
43
          :documentation "")
44
    (mcadr :initarg :mcadr
45
           :accessor mcadr
46
           :documentation "")))
47
 
48
 (defclass / (<poly>)
49
   ((mcar :initarg :mcar
50
          :accessor mcar
51
          :documentation "")
52
    (mcadr :initarg :mcadr
53
           :accessor mcadr
54
           :documentation "")))
55
 
56
 (defclass mod (<poly>)
57
   ((mcar :initarg :mcar
58
          :accessor mcar
59
          :documentation "")
60
    (mcadr :initarg :mcadr
61
           :accessor mcadr
62
           :documentation "")))
63
 
64
 (defclass if-zero (<poly>)
65
   ((predicate :initarg :predicate
66
               :accessor predicate
67
               :documentation "")
68
    (then :initarg :then
69
          :accessor then
70
          :documentation "")
71
    (else :initarg :else
72
          :accessor else
73
          :documentation ""))
74
   (:documentation "compare with zero: equal takes first branch;
75
                    not-equal takes second branch"))
76
 (defclass if-lt (<poly>)
77
   ((mcar :initarg :mcar
78
          :accessor mcar
79
          :documentation "")
80
    (mcadr :initarg :mcadr
81
           :accessor mcadr
82
           :documentation "")
83
    (then :initarg :then
84
          :accessor then
85
          :documentation "")
86
    (else :initarg :else
87
          :accessor else
88
          :documentation ""))
89
   (:documentation
90
    "If the [MCAR] argument is strictly less than the [MCADR] then the
91
     [THEN] branch is taken, otherwise the [ELSE] branch is taken."))
92
 
93
 (defmethod mcar ((obj if-zero))
94
   (predicate obj))
95
 
96
 (defmethod mcadr ((obj if-zero))
97
   (then obj))
98
 
99
 (defmethod mcaddr ((obj if-zero))
100
   (else obj))
101
 
102
 (defmethod mcaddr ((obj if-lt))
103
   (then obj))
104
 
105
 (defmethod mcadddr ((obj if-lt))
106
   (else obj))
107
 
108
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
109
 ;; Constructors
110
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
111
 
112
 (defmacro make-multi (constructor)
113
   `(defun ,constructor (mcar mcadr &rest args)
114
      ,(format nil "Creates a multiway constructor for [~A]" constructor)
115
      (reduce (lambda (x y)
116
                (make-instance ',constructor :mcar x :mcadr y))
117
              (list* mcar mcadr args)
118
              :from-end t)))
119
 
120
 (make-multi +)
121
 (make-multi *)
122
 (make-multi compose)
123
 (make-multi /)
124
 (make-multi -)
125
 
126
 (defun mod (mcar mcadr)
127
   "MOD ARG1 by ARG2"
128
   (make-instance 'mod :mcar mcar :mcadr mcadr))
129
 
130
 (defun if-zero (pred then else)
131
   "checks if [PREDICATE] is zero then take the [THEN] branch otherwise
132
 the [ELSE] branch"
133
   (make-instance 'if-zero :predicate pred :then then :else else))
134
 
135
 (defun if-lt (mcar mcadr then else)
136
   "Checks if the [MCAR] is less than the [MCADR] and chooses the appropriate branch"
137
   (make-instance 'if-lt :mcar mcar :mcadr mcadr :then then :else else))
138
 
139
 (serapeum:def ident (make-instance 'ident))
140
 
141
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
142
 ;; Pattern Matching
143
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
144
 
145
 ;; Ι don't do multi way pattern matching yet :(
146
 (make-pattern +       mcar mcadr)
147
 (make-pattern *       mcar mcadr)
148
 (make-pattern /       mcar mcadr)
149
 (make-pattern -       mcar mcadr)
150
 (make-pattern compose mcar mcadr)
151
 (make-pattern mod     mcar mcadr)
152
 (make-pattern if-zero predicate  then else)
153
 (make-pattern if-lt   mcar mcadr then else)
154
 �