Coverage report: /home/ati/workspace/perec/util/duplicates.lisp

KindCoveredAll%
expression152236 64.4
branch1718 94.4
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
2
 ;;;
3
 ;;; Copyright (c) 2006 by the authors.
4
 ;;;
5
 ;;; See LICENCE for details.
6
 
7
 (in-package :cl-perec)
8
 
9
 ;;; THE CONTENT OF THIS FILE IS COPIED OVER FROM SOME OTHER LIBRARIES TO DECREASE THE NUMBER OF DEPENDENCIES
10
 
11
 (set-dispatch-macro-character
12
  #\# #\t
13
  (lambda (s c n)
14
    (declare (ignore s c n))
15
    t))
16
 
17
 (set-dispatch-macro-character
18
  #\# #\f
19
  (lambda (s c n)
20
    (declare (ignore s c n))
21
    nil))
22
 
23
 (defmacro debug-only (&body body)
24
   #+debug`(progn ,@body)
25
   #-debug(declare (ignore body)))
26
 
27
 (defun canonical-symbol-name (symbol)
28
   "Returns the package name and symbol name concatenated."
29
   (strcat
30
    (package-name (symbol-package symbol))
31
    "::"
32
    (symbol-name symbol)))
33
 
34
 (defun symbol-from-canonical-name (name)
35
   (read-from-string name))
36
 
37
 (defun concatenate-symbol (&rest args)
38
   "Args are processed as parts of the result symbol with an exception: when a package is encountered then it is stored as the target package at intern."
39
   (let* ((package nil)
40
          (symbol-name (string-upcase
41
                        (with-output-to-string (str)
42
                          (dolist (arg args)
43
                            (typecase arg
44
                              (string (write-string arg str))
45
                              (package (setf package arg))
46
                              (symbol (unless package
47
                                        (setf package (symbol-package arg)))
48
                                      (write-string (symbol-name arg) str))
49
                              (integer (write-string (princ-to-string arg) str))
50
                              (character (write-char arg) str)
51
                              (t (error "Cannot convert argument ~S to symbol" arg))))))))
52
     (if package
53
         (intern symbol-name package)
54
         (intern symbol-name))))
55
 
56
 (defmacro delete! (object place)
57
   `(setf ,place
58
     (delete ,object ,place)))
59
 
60
 (defun find-slot (class-or-name slot-name)
61
   (find slot-name
62
         (class-slots (if (symbolp class-or-name)
63
                          (find-class class-or-name)
64
                          class-or-name))
65
         :key 'slot-definition-name))
66
 
67
 (defmacro aprog1 (ret &body body)
68
   `(prog1-bind it ,ret ,@body))
69
 
70
 (defmacro prog1-bind (var ret &body body)
71
   `(bind ((,var ,ret))
72
     ,@body
73
     ,var))
74
 
75
 (defun hasf (plist indicator)
76
   (not (eq (getf plist indicator :unbound) :unbound)))
77
 
78
 (defun collect-if (predicate sequence)
79
   "Collect elements from SEQUENCE for which the PREDICATE is true."
80
   (remove-if-not predicate sequence))
81
 
82
 (defun length=1 (list)
83
   "Returns t if the length of the LIST is 1. (Faster than (eq (length list) 1))"
84
   (and (consp list)
85
        (null (rest list))))
86
 
87
 (defun mappend (function &rest lists)
88
   "Same as mapcar except the results are appended."  
89
   (apply 'append (apply 'mapcar function lists)))
90
 
91
 (defmacro appendf (place &rest lists)
92
   "Like append, but setfs back the result"
93
   `(setf ,place (append ,place ,@lists)))
94
 
95
 (defmacro nconcf (place &rest lists)
96
   `(setf ,place (nconc ,place ,@lists)))
97
 
98
 (defun rcons (car cdr cons)
99
   "Returns a cons having CAR as car and CDR as cdr reusing CONS if possible."
100
   (if (and (eq car (car cons)) (eq cdr (cdr cons)))
101
       cons
102
       (cons car cdr)))
103
 
104
 (defun tree-substitute (new old list
105
                             &key from-end (test #'eql) (test-not nil)
106
                             (end nil) (count nil) (key nil) (start 0))
107
   "Starting from LIST non-destructively replaces OLD with NEW."
108
   (if (consp list)
109
       (prog1-bind result
110
         (iter (for newitem in (ensure-list new))
111
               (for olditem in (ensure-list old))
112
               (setf list (substitute newitem olditem list :from-end from-end :test test :test-not test-not
113
                                      :end end :count count :key key :start start))
114
               (finally (return list)))
115
         (iter (for node first result then (cdr node))
116
               (until (null node))
117
               (for el = (car node))
118
               (setf (car node) (tree-substitute new old el :from-end from-end :test test :test-not test-not
119
                                                 :end end :count count :key key :start start))))
120
       (if (funcall test list old)
121
           new
122
           list)))
123
 
124
 (defun not-yet-implemented (&optional (datum "Not yet implemented." datum-p) &rest args)
125
   (when datum-p
126
     (setf datum (strcat "Not yet implemented: " datum)))
127
   (apply #'cerror "Ignore and continue" datum args))
128
 
129
 (defmacro bind-cartesian-product (((&rest variables) lst) &body body)
130
   (labels ((generate (variables l)
131
              (if (cdr variables) 
132
                  `(dolist (,(car variables) ,l)
133
                    ,(generate (cdr variables) l))
134
                  `(dolist (,(car variables) ,l)
135
                    ,@body))))
136
     (if variables
137
         (with-unique-names (l)
138
           `(let ((,l ,lst))
139
             ,(generate variables l)))
140
         nil)))
141
 
142
 (defun lessp (obj1 obj2)
143
   (typecase obj1
144
     (real (< obj1 obj2))
145
     (string (string< obj1 obj2))
146
     (character (char< obj1 obj2))))
147
 
148
 (defun less-or-equal-p (obj1 obj2)
149
   (typecase obj1
150
     (real (<= obj1 obj2))
151
     (string (string<= obj1 obj2))
152
     (character (char<= obj1 obj2))))
153
 
154
 (defun greaterp (obj1 obj2)
155
   (typecase obj1
156
     (real (> obj1 obj2))
157
     (string (string> obj1 obj2))
158
     (character (char> obj1 obj2))))
159
 
160
 (defun greater-or-equal-p (obj1 obj2)
161
   (typecase obj1
162
     (real (>= obj1 obj2))
163
     (string (string>= obj1 obj2))
164
     (character (char>= obj1 obj2))))