Skip to content
Newer
Older
100644 324 lines (279 sloc) 11.1 KB
4d2defd @davazp Move utilities to utils.lisp
authored
1 ;; utils.lisp
2 ;;
3 ;; Copyrigth (C) 2009, 2010 Mario Castelán Castro <marioxcc>
4 ;; Copyrigth (C) 2009, 2010 David Vázquez
5 ;;
6 ;; This file is part of cl-icalendar.
7 ;;
8 ;; cl-icalendar is free software: you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
12 ;;
13 ;; cl-icalendar is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
17 ;;
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with cl-icalendar. If not, see <http://www.gnu.org/licenses/>.
20
21 (in-package :cl-icalendar)
22
6cc8d13 @davazp More refactoring.
authored
23 ;;;; Misc macros
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
24
4d2defd @davazp Move utilities to utils.lisp
authored
25 (defmacro while (condition &body code)
26 `(do ()
27 ((not ,condition))
28 ,@code))
29
30 (defmacro with-gensyms ((&rest vars) &body code)
66813cf Now with-gensyms allows to specify a parameter for gensym but mantains
Mario Castelan Castro authored
31 `(let ,(loop for i in vars
32 collect (etypecase i
d41f455 with-gensyms now sets smartly the default parameter to gensym.
Mario Castelan Castro authored
33 (symbol `(,i (gensym ,(symbol-name i))))
66813cf Now with-gensyms allows to specify a parameter for gensym but mantains
Mario Castelan Castro authored
34 (list `(,(first i) (gensym ,(second i))))))
4d2defd @davazp Move utilities to utils.lisp
authored
35 ,@code))
36
dbf387f @davazp Rename with-collecting to with-collect.
authored
37 (defmacro with-collect (&body code)
4d2defd @davazp Move utilities to utils.lisp
authored
38 (with-gensyms (collected tail)
39 `(let* ((,collected (list '#:collect))
40 (,tail ,collected))
41 (flet ((collect (x)
42 (setf (cdr ,tail) (list x))
43 (setf ,tail (cdr ,tail))))
44 ,@code)
45 (cdr ,collected))))
46
aecf279 @davazp BYDAY parse and format
authored
47 ;;; Iteration form is based in Scheme named-let. It bounds NAME to a
48 ;;; local function which ARG arguments and body CODE. ARGS is like an
49 ;;; ordinary lambda form, but the required arguments are specified as
50 ;;; a two-list, where the first element is the variable name and the
51 ;;; second is the initial value.
52 (defmacro iteration (name args &body code)
53 (let* ((required-args-count
54 ;; Number of required arguments
55 (loop for keyword in lambda-list-keywords
56 for pos = (position keyword args)
57 when pos
58 minimizing pos into aux
59 finally (return (if (null pos) (length args) aux))))
60 ;; List of required arguments
61 (required-args (subseq args 0 required-args-count))
62 ;; List of optional arguments
63 (non-required (nthcdr required-args-count args)))
64 ;; Check extended lambda form is well formed.
65 (dolist (arg required-args)
66 (unless (= (length arg) 2)
67 (error "Iterate form ill-formed.")))
68 (let* ((required-args-names (mapcar #'first required-args))
69 (initial-arg-values (mapcar #'second required-args))
70 (function-lambda (append required-args-names non-required)))
71 `(labels ((,name ,function-lambda
72 (block nil ,@code)))
73 (,name ,@initial-arg-values)))))
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
74
75 ;;;; Declarations and definitions facilities
76
77 ;;; Like `defun' but declare the function as inline.
78 (defmacro definline (name args &body body)
79 `(progn
80 (declaim (inline ,name))
81 (defun ,name ,args ,@body)))
82
f42fa62 @davazp More documentation.
authored
83 ;;; Define a variable-arity transitive predicate from a body which
84 ;;; define a transtivie relation of arity 2. The body is contained in
85 ;;; an implicit block.
8cf9aca @davazp Changes to time functions.
authored
86 (defmacro define-transitive-relation (name (arg1 arg2) &body body)
50137bf @davazp Simplify `define-transitive-relation'.
authored
87 (with-gensyms (argsvar)
8cf9aca @davazp Changes to time functions.
authored
88 `(defun ,name (&rest ,argsvar)
50137bf @davazp Simplify `define-transitive-relation'.
authored
89 (loop for (,arg1 ,arg2) on ,argsvar
90 while ,arg2
0d603bb @davazp char-ci= and string-ci= are n-arity now.
authored
91 always
92 (block nil
f42fa62 @davazp More documentation.
authored
93 ((lambda () ,@body)))))))
c7060fa @davazp Duration accessors work with durspec. Relational functions for duration.
authored
94
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
95 ;;; Define a predicate named NAME in order to check if the type of an
96 ;;; object is TYPE. If NAME is omitted, NAMEP is used.
97 (defmacro define-predicate-type (type &optional name)
98 (declare (type (or symbol null) name))
99 (let ((fname (or name (intern (format nil "~aP" type)))))
100 `(defun ,fname (x)
101 (typep x ',type))))
102
103 ;;; Mark a function as deprecated. When FUNCTION is called, it signals
104 ;;; a simple warning. If REPLACEMENT is given, it will recommend to
105 ;;; use REPLACEMENT indeed.
106 ;;;
107 ;;; FUNCTION and REPLACEMENT are symbols.
108 (defmacro deprecate-function (function &body ignore &key replacement)
109 (declare (ignore ignore))
110 (declare (symbol function replacement))
111 `(define-compiler-macro ,function (&whole form &rest args)
112 (declare (ignore args))
113 (warn "Function ~a is deprecated. ~@[Use ~a indeed.~]"
114 ',function ',replacement)
115 form))
116
117
118 ;;;; Sequences
119
6cc8d13 @davazp More refactoring.
authored
120 ;; TODO: Enhanche this with a optional finally section, mantaning
121 ;; backward compatibility is not need
122 (defun %do-sequence (function sequence &key (start 0) end)
123 (etypecase sequence
124 (list
125 (if (not end)
126 (loop for x in (nthcdr start sequence) do (funcall function x))
127 (loop for x in (nthcdr start sequence)
128 for i from start below end
129 do (funcall function x))))
130 (sequence
131 (loop for i from start below (or end (length sequence))
132 for x = (elt sequence i)
133 do (funcall function x)))))
134
135 ;;; Iterate for the elements of a sequence for side efects, from the
136 ;;; START position element until the END position element. If END is
137 ;;; omitted, then it iterates for all elements of sequence.
138 (defmacro do-sequence ((var sequence &key (start 0) end) &body body)
139 (declare (symbol var))
140 `(%do-sequence (lambda (,var) ,@body)
141 ,sequence
142 :start ,start
143 :end ,end))
144
f42fa62 @davazp More documentation.
authored
145 ;;; Return a fresh copy subsequence of SEQ bound from 0 until the
146 ;;; first element what verifies the FUNC predicate.
205ce26 @davazp New `strip-if' and `strip' functions.
authored
147 (defun strip-if (func seq &rest rest &key &allow-other-keys)
148 (subseq seq 0 (apply #'position-if func seq rest)))
4d2defd @davazp Move utilities to utils.lisp
authored
149
f42fa62 @davazp More documentation.
authored
150 ;;; Return a fresh copy subsequence of SEQ bound from 0 until the
151 ;;; position of X in sequence.
205ce26 @davazp New `strip-if' and `strip' functions.
authored
152 (defun strip (x seq &rest rest &key &allow-other-keys)
153 (subseq seq 0 (apply #'position x seq rest)))
4d2defd @davazp Move utilities to utils.lisp
authored
154
f42fa62 @davazp More documentation.
authored
155 ;;; Make sure that ITEM is an element of LIST, otherwise this function
156 ;;; signals an simple-error condtion.
23f27ba check-member added.
Mario Castelan Castro authored
157 (defmacro check-member (item list &key (test #'eql))
158 `(if (not (position ,item ',list :test ,test))
159 (error "Not a member of the specified list")))
160
c4e933c @davazp Fix do-sequence.
authored
161 ;;; Like `some', but it works on bound sequences
6a15c9e do-string renamed do-sequence.
Mario Castelan Castro authored
162 (defun some* (predicate sequence &key (start 0) end)
c4e933c @davazp Fix do-sequence.
authored
163 (do-sequence (item sequence :start start :end end)
164 (when (funcall predicate item)
165 (return-from some* t)))
166 nil)
6a15c9e do-string renamed do-sequence.
Mario Castelan Castro authored
167
ada45e4 @davazp split-string added.
authored
168 (defun split-string (string &optional (separators " ") (omit-nulls t))
169 (declare (type string string))
170 (flet ((separator-p (char)
171 (etypecase separators
172 (character (char= char separators))
173 (sequence (find char separators))
174 (function (funcall separators char)))))
175 (loop for start = 0 then (1+ end)
176 for end = (position-if #'separator-p string :start start)
177 as seq = (subseq string start end)
178 unless (and omit-nulls (string= seq ""))
87c8934 @davazp Bug fix in %do-sequence. More documenumentation. Indentation
authored
179 collect seq
ada45e4 @davazp split-string added.
authored
180 while end)))
181
87c8934 @davazp Bug fix in %do-sequence. More documenumentation. Indentation
authored
182 ;;; Concatenate the list of STRINGS.
82ed816 @davazp format-values and some documentation.
authored
183 (defun join-strings (strings &optional (separator #\space))
184 (if (null strings)
185 (make-string 0)
186 (reduce (lambda (s1 s2)
187 (concatenate 'string s1 (string separator) s2))
188 strings)))
189
87c8934 @davazp Bug fix in %do-sequence. More documenumentation. Indentation
authored
190 ;;; Check if there is duplicated elements in LIST. KEY functions are
bf500eb @davazp Fix typos.
authored
191 ;;; applied to elements previosly. The elements are compared by TEST
87c8934 @davazp Bug fix in %do-sequence. More documenumentation. Indentation
authored
192 ;;; function.
de801f5 @davazp Draft for recur parser added.
authored
193 (defun duplicatep (list &key (test #'eql) (key #'identity))
194 (and (loop for x on list
195 for a = (funcall key (car x))
196 for b = (cdr x)
197 thereis (find a b :key key :test test))
198 t))
199
aecf279 @davazp BYDAY parse and format
authored
200 ;;; Return the list of elements which appear in preorder in a tree. If
201 ;;; LIMIT is non-nil, it is a non-negative integer which specify the
202 ;;; deepest level in the tree. Otherwise, it falls until atom
203 ;;; elements.
204 (defun flatten (tree &optional limit)
205 (declare (list tree) (type (or unsigned-byte null) limit))
206 (iteration looping ((x tree) (k limit))
207 (cond
208 ((null x) '())
209 ((atom x) (list x))
210 ((consp x)
211 (if (and limit (zerop k))
212 x
213 (append (looping (car x) (and limit (1- k)))
214 (looping (cdr x) k)))))))
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
215
216 ;;;; Streams
217 ;;; Read characters from STREAM until it finds a char of CHAR-BAG. If
218 ;;; it finds a NON-EXPECT character, it signals an error. If an end of
219 ;;; file condition is signaled and EOF-ERROR-P is nil, return nil.
220 (defun read-until (stream char-bag &optional (not-expect "") (eof-error-p t))
221 (flet (;; Check if CH is a terminal char
222 (terminal-char-p (ch)
223 (etypecase char-bag
224 (character (char= ch char-bag))
225 (sequence (find ch char-bag :test #'char=))
226 (function (funcall char-bag ch))))
227 ;; Check if CH is not an expected char
228 (not-expect-char-p (ch)
229 (etypecase not-expect
230 (character (char= ch not-expect))
231 (sequence (find ch not-expect :test #'char=))
232 (function (funcall not-expect ch)))))
233 ;; Read characters
234 (with-output-to-string (out)
235 (loop for ch = (peek-char nil stream eof-error-p)
236 until (and (not eof-error-p) (null ch))
237 until (terminal-char-p ch)
238 when (not-expect-char-p ch)
239 do (error "Character ~w is not expected." ch)
240 do (write-char (read-char stream) out)))))
241
242
243 ;;;; Comparators
244
bf500eb @davazp Fix typos.
authored
245 ;;; Like `char=' but it is case-insensitive.
4da92bd @davazp Revert last commit.
authored
246 (defun char-ci= (char1 char2)
1de8a7d @davazp Rewrite string-ci= to use char-ci=
authored
247 (declare (character char1 char2))
248 (char= (char-upcase char1)
249 (char-upcase char2)))
250
41cb4d8 @davazp Function string-ci= added.
authored
251 ;;; Like `string=' but it is case-insensitive.
4da92bd @davazp Revert last commit.
authored
252 (defun string-ci= (str1 str2)
253 (declare (string str1 str2))
7d7ce50 @davazp Recur advances and boolean unit tests added.
authored
254 (and (= (length str1) (length str2))
255 (every #'char-ci= str1 str2)))
41cb4d8 @davazp Function string-ci= added.
authored
256
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
257 ;;; Check if X and Y are not eq.
258 (definline neq (x y)
259 (not (eq x y)))
10e46ed @davazp define-predicate-type macro added.
authored
260
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
261 ;;; Anaphoric IF.
262 (defmacro aif (condition then &optional else)
263 `(let ((it ,condition))
264 (if it ,then ,else)))
265
266
6cc8d13 @davazp More refactoring.
authored
267 ;;;; setf-based
268
269 ;;; Set PLACE to 0
270 (defmacro zerof (place)
271 `(setf ,place 0))
272
273 ;;; Set PLACE to nil.
274 (defmacro nilf (place)
275 `(setf ,place nil))
276
277 ;;; (modf place N) set place to (mod place N)
278 (define-modify-macro modf (n) mod)
279
280
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
281 ;;;; Others
282
283 ;;; Like `parse-integer' but it is not allowed to have a sign (+\-).
d52f6bc @davazp Fix bug in parse-unsigned-integer.
authored
284 (defun parse-unsigned-integer (string &rest keyargs &key (start 0) end &allow-other-keys)
285 (unless (or (eql start end) (digit-char-p (elt string start)))
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
286 (error "~w is not an unsigned integer." string))
287 (apply #'parse-integer string keyargs))
288
289 ;;; Integer division
290 (definline idiv (a b)
291 (declare (integer a b)
292 (optimize speed))
293 (values (truncate a b)))
294
295 ;;; Check if N divides to M.
296 (definline divisiblep (m n)
297 (declare (integer m n))
298 (zerop (mod m n)))
10e46ed @davazp define-predicate-type macro added.
authored
299
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
300 ;;; Set PLACE to zero.
87c8934 @davazp Bug fix in %do-sequence. More documenumentation. Indentation
authored
301 ;;; This function is thought to use this function as default-value in
302 ;;; optional or keyword arguments.
303 (defun required-arg ()
304 (error "A required &KEY or &OPTIONAL argument was not supplied."))
305
e8c5ff2 @davazp New /debug macro, and use in recur data type.
authored
306 ;;; Like `(format t ...)', useful for debugging.
307 (defmacro /debug (form)
308 #+cl-icalendar-debug
309 (with-gensyms (value)
310 `(progn
311 (let ((,value ,form))
312 (format *error-output* "~%; DEBUG~@[ (~a)~]"
313 (load-time-value (aif *load-pathname* (enough-namestring it))))
314 (pprint ',form *error-output*)
315 (write-string " ===> " *error-output*)
316 (princ ,value *error-output*)
317 (terpri *error-output*)
318 ,value)))
319 #-cl-icalendar-debug
320 form)
321
6cc8d13 @davazp More refactoring.
authored
322
4d2defd @davazp Move utilities to utils.lisp
authored
323 ;;; utils.lisp ends here
Something went wrong with that request. Please try again.