Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 444 lines (381 sloc) 15.469 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
30223d7 @davazp with-collectors macro.
authored
25 (eval-when (:compile-toplevel :load-toplevel :execute)
26 (defun symbolize (symbol1 symbol2)
27 (intern (concatenate 'string (string symbol1) (string symbol2)))))
28
4d2defd @davazp Move utilities to utils.lisp
authored
29 (defmacro while (condition &body code)
30 `(do ()
31 ((not ,condition))
32 ,@code))
33
34 (defmacro with-gensyms ((&rest vars) &body code)
66813cf Now with-gensyms allows to specify a parameter for gensym but mantains
Mario Castelan Castro authored
35 `(let ,(loop for i in vars
36 collect (etypecase i
d41f455 with-gensyms now sets smartly the default parameter to gensym.
Mario Castelan Castro authored
37 (symbol `(,i (gensym ,(symbol-name i))))
66813cf Now with-gensyms allows to specify a parameter for gensym but mantains
Mario Castelan Castro authored
38 (list `(,(first i) (gensym ,(second i))))))
4d2defd @davazp Move utilities to utils.lisp
authored
39 ,@code))
e371191 @davazp once-only macro.
authored
40
41 ;;; The famous macro once-only macro.
42 ;;; FIXME: How ugly is! Write a more beautiful implementation. This would be both
43 ;;; more verbose, and clearer.
44 (defmacro once-only ((&rest names) &body body)
45 (let ((gensyms (loop for n in names collect (gensym))))
46 `(let (,@(loop for g in gensyms collect `(,g (gensym))))
47 `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
48 ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
49 ,@body)))))
50
30223d7 @davazp with-collectors macro.
authored
51 ;;; TODO: Document me!
52 (defmacro with-collectors ((&rest names) &body code)
53 (let ((names (mapcar #'mklist names))
871d0bd @davazp collect-* functions return the collected list.
authored
54 ;; A list of lists of the form (NAME INITFORM BEGIN END
55 ;; FNAME), where BEGIN and END are the gensymed symbols of the
56 ;; first and the last cons of the collector. Note we use a
57 ;; special header cons.
30223d7 @davazp with-collectors macro.
authored
58 (table nil))
5ad4737 @davazp Fix comment
authored
59 ;; Fill the table
30223d7 @davazp with-collectors macro.
authored
60 (dolist (collector names)
9280b06 @davazp Rewrite with-collect in terms of with-collectors.
authored
61 (destructuring-bind (name &optional initform fname) collector
62 (push (list name
63 initform
64 (gensym)
65 (gensym)
66 (or fname (symbolize 'collect- name)))
67 table)))
30223d7 @davazp with-collectors macro.
authored
68 (macrolet (;; Map through collectors binding NAME INITFORM BEGIN
69 ;; and END variables, collecting the results in a list.
70 (map* (form)
9280b06 @davazp Rewrite with-collect in terms of with-collectors.
authored
71 `(loop for (name initform begin end fname)
30223d7 @davazp with-collectors macro.
authored
72 in table
73 collect ,form)))
74 ;; Macroexpansion
75 `(let ,(map* `(,begin (cons :collector ,initform)))
76 (let ,(map* `(,end (last ,begin)))
77 (symbol-macrolet ,(map* `(,name (cdr ,begin)))
9280b06 @davazp Rewrite with-collect in terms of with-collectors.
authored
78 (flet ,(map* `(,fname (value)
79 (setf (cdr ,end) (list value))
871d0bd @davazp collect-* functions return the collected list.
authored
80 (setf ,end (cdr ,end))
81 (cdr ,begin)))
30223d7 @davazp with-collectors macro.
authored
82 ,@code)))))))
83
9280b06 @davazp Rewrite with-collect in terms of with-collectors.
authored
84 ;;; TODO: Document me!
85 (defmacro with-collect (&body code)
86 (with-gensyms (name)
87 `(with-collectors ((,name nil collect))
88 ,@code
89 ,name)))
90
30223d7 @davazp with-collectors macro.
authored
91
aecf279 @davazp BYDAY parse and format
authored
92 ;;; Iteration form is based in Scheme named-let. It bounds NAME to a
93 ;;; local function which ARG arguments and body CODE. ARGS is like an
94 ;;; ordinary lambda form, but the required arguments are specified as
95 ;;; a two-list, where the first element is the variable name and the
96 ;;; second is the initial value.
97 (defmacro iteration (name args &body code)
98 (let* ((required-args-count
99 ;; Number of required arguments
100 (loop for keyword in lambda-list-keywords
101 for pos = (position keyword args)
102 when pos
103 minimizing pos into aux
104 finally (return (if (null pos) (length args) aux))))
105 ;; List of required arguments
106 (required-args (subseq args 0 required-args-count))
107 ;; List of optional arguments
108 (non-required (nthcdr required-args-count args)))
109 ;; Check extended lambda form is well formed.
110 (dolist (arg required-args)
111 (unless (= (length arg) 2)
112 (error "Iterate form ill-formed.")))
113 (let* ((required-args-names (mapcar #'first required-args))
114 (initial-arg-values (mapcar #'second required-args))
115 (function-lambda (append required-args-names non-required)))
116 `(labels ((,name ,function-lambda
117 (block nil ,@code)))
118 (,name ,@initial-arg-values)))))
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
119
120 ;;;; Declarations and definitions facilities
121
122 ;;; Like `defun' but declare the function as inline.
123 (defmacro definline (name args &body body)
124 `(progn
125 (declaim (inline ,name))
126 (defun ,name ,args ,@body)))
127
f42fa62 @davazp More documentation.
authored
128 ;;; Define a variable-arity transitive predicate from a body which
129 ;;; define a transtivie relation of arity 2. The body is contained in
130 ;;; an implicit block.
8cf9aca @davazp Changes to time functions.
authored
131 (defmacro define-transitive-relation (name (arg1 arg2) &body body)
50137bf @davazp Simplify `define-transitive-relation'.
authored
132 (with-gensyms (argsvar)
8cf9aca @davazp Changes to time functions.
authored
133 `(defun ,name (&rest ,argsvar)
50137bf @davazp Simplify `define-transitive-relation'.
authored
134 (loop for (,arg1 ,arg2) on ,argsvar
135 while ,arg2
0d603bb @davazp char-ci= and string-ci= are n-arity now.
authored
136 always
137 (block nil
f42fa62 @davazp More documentation.
authored
138 ((lambda () ,@body)))))))
c7060fa @davazp Duration accessors work with durspec. Relational functions for duration.
authored
139
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
140 ;;; Define a predicate named NAME in order to check if the type of an
141 ;;; object is TYPE. If NAME is omitted, NAMEP is used.
142 (defmacro define-predicate-type (type &optional name)
143 (declare (type (or symbol null) name))
144 (let ((fname (or name (intern (format nil "~aP" type)))))
145 `(defun ,fname (x)
146 (typep x ',type))))
147
148 ;;; Mark a function as deprecated. When FUNCTION is called, it signals
149 ;;; a simple warning. If REPLACEMENT is given, it will recommend to
150 ;;; use REPLACEMENT indeed.
151 ;;;
152 ;;; FUNCTION and REPLACEMENT are symbols.
153 (defmacro deprecate-function (function &body ignore &key replacement)
154 (declare (ignore ignore))
155 (declare (symbol function replacement))
156 `(define-compiler-macro ,function (&whole form &rest args)
157 (declare (ignore args))
158 (warn "Function ~a is deprecated. ~@[Use ~a indeed.~]"
159 ',function ',replacement)
160 form))
161
162
163 ;;;; Sequences
164
6cc8d13 @davazp More refactoring.
authored
165 ;; TODO: Enhanche this with a optional finally section, mantaning
166 ;; backward compatibility is not need
167 (defun %do-sequence (function sequence &key (start 0) end)
168 (etypecase sequence
169 (list
170 (if (not end)
171 (loop for x in (nthcdr start sequence) do (funcall function x))
172 (loop for x in (nthcdr start sequence)
173 for i from start below end
174 do (funcall function x))))
175 (sequence
176 (loop for i from start below (or end (length sequence))
177 for x = (elt sequence i)
178 do (funcall function x)))))
179
180 ;;; Iterate for the elements of a sequence for side efects, from the
181 ;;; START position element until the END position element. If END is
182 ;;; omitted, then it iterates for all elements of sequence.
183 (defmacro do-sequence ((var sequence &key (start 0) end) &body body)
184 (declare (symbol var))
185 `(%do-sequence (lambda (,var) ,@body)
186 ,sequence
187 :start ,start
188 :end ,end))
189
f42fa62 @davazp More documentation.
authored
190 ;;; Return a fresh copy subsequence of SEQ bound from 0 until the
191 ;;; first element what verifies the FUNC predicate.
205ce26 @davazp New `strip-if' and `strip' functions.
authored
192 (defun strip-if (func seq &rest rest &key &allow-other-keys)
193 (subseq seq 0 (apply #'position-if func seq rest)))
4d2defd @davazp Move utilities to utils.lisp
authored
194
f42fa62 @davazp More documentation.
authored
195 ;;; Return a fresh copy subsequence of SEQ bound from 0 until the
196 ;;; position of X in sequence.
205ce26 @davazp New `strip-if' and `strip' functions.
authored
197 (defun strip (x seq &rest rest &key &allow-other-keys)
198 (subseq seq 0 (apply #'position x seq rest)))
4d2defd @davazp Move utilities to utils.lisp
authored
199
f42fa62 @davazp More documentation.
authored
200 ;;; Make sure that ITEM is an element of LIST, otherwise this function
201 ;;; signals an simple-error condtion.
23f27ba check-member added.
Mario Castelan Castro authored
202 (defmacro check-member (item list &key (test #'eql))
203 `(if (not (position ,item ',list :test ,test))
204 (error "Not a member of the specified list")))
205
c4e933c @davazp Fix do-sequence.
authored
206 ;;; Like `some', but it works on bound sequences
0c18783 @davazp %unbound-recur-instance-p use %complete-recur.
authored
207 (defun some* (predicate sequence &key (start 0) end (key #'identity))
c4e933c @davazp Fix do-sequence.
authored
208 (do-sequence (item sequence :start start :end end)
0c18783 @davazp %unbound-recur-instance-p use %complete-recur.
authored
209 (when (funcall predicate (funcall key item))
c4e933c @davazp Fix do-sequence.
authored
210 (return-from some* t)))
211 nil)
6a15c9e do-string renamed do-sequence.
Mario Castelan Castro authored
212
ada45e4 @davazp split-string added.
authored
213 (defun split-string (string &optional (separators " ") (omit-nulls t))
214 (declare (type string string))
215 (flet ((separator-p (char)
216 (etypecase separators
217 (character (char= char separators))
218 (sequence (find char separators))
219 (function (funcall separators char)))))
220 (loop for start = 0 then (1+ end)
221 for end = (position-if #'separator-p string :start start)
222 as seq = (subseq string start end)
223 unless (and omit-nulls (string= seq ""))
87c8934 @davazp Bug fix in %do-sequence. More documenumentation. Indentation
authored
224 collect seq
ada45e4 @davazp split-string added.
authored
225 while end)))
226
5cfcc54 @davazp rcurry added.
authored
227 ;;; Concatenate strings.
228 (defun concat (&rest strings)
229 (if (null strings)
230 (make-string 0)
231 (reduce (lambda (s1 s2)
232 (concatenate 'string s1 s2))
233 strings)))
234
87c8934 @davazp Bug fix in %do-sequence. More documenumentation. Indentation
authored
235 ;;; Concatenate the list of STRINGS.
82ed816 @davazp format-values and some documentation.
authored
236 (defun join-strings (strings &optional (separator #\space))
237 (if (null strings)
238 (make-string 0)
239 (reduce (lambda (s1 s2)
240 (concatenate 'string s1 (string separator) s2))
241 strings)))
242
87c8934 @davazp Bug fix in %do-sequence. More documenumentation. Indentation
authored
243 ;;; Check if there is duplicated elements in LIST. KEY functions are
bf500eb @davazp Fix typos.
authored
244 ;;; applied to elements previosly. The elements are compared by TEST
87c8934 @davazp Bug fix in %do-sequence. More documenumentation. Indentation
authored
245 ;;; function.
de801f5 @davazp Draft for recur parser added.
authored
246 (defun duplicatep (list &key (test #'eql) (key #'identity))
247 (and (loop for x on list
248 for a = (funcall key (car x))
249 for b = (cdr x)
250 thereis (find a b :key key :test test))
251 t))
252
aecf279 @davazp BYDAY parse and format
authored
253 ;;; Return the list of elements which appear in preorder in a tree. If
254 ;;; LIMIT is non-nil, it is a non-negative integer which specify the
255 ;;; deepest level in the tree. Otherwise, it falls until atom
256 ;;; elements.
257 (defun flatten (tree &optional limit)
258 (declare (list tree) (type (or unsigned-byte null) limit))
259 (iteration looping ((x tree) (k limit))
260 (cond
261 ((null x) '())
262 ((atom x) (list x))
263 ((consp x)
264 (if (and limit (zerop k))
265 x
266 (append (looping (car x) (and limit (1- k)))
267 (looping (cdr x) k)))))))
1a14874 @davazp remove-nth and delete-nth utility functions.
authored
268
269
270 ;;; Return a list with the nth element of list removed.
271 (defun remove-nth (n list)
272 (let* ((result (cons nil nil))
273 (tail result))
274 (do ((i 0 (1+ i))
275 (l list (cdr l)))
276 ((or (= i n) (null l))
277 (setf (cdr tail) (cdr l))
278 (cdr result))
279 (setf (cdr tail) (cons (car l) nil))
280 (setf tail (cdr tail)))))
281
282 ;;; delete-nth is as remove-nth but it could modify the list.
283 ;;;
284 ;;; NOTE: if you want delete the nth element of the value of a
285 ;;; variable V, you should use '(setf v (delete-nth n v))', indeed of
286 ;;; '(delete-nth n v)', just as the standard delete function.
287 (defun delete-nth (n list)
288 (declare (type (integer 0 *) n) (list list))
289 (if (zerop n)
290 (cdr list)
291 (let ((tail (nthcdr (1- n) list)))
292 (setf (cdr tail) (cddr tail))
293 list)))
22be7e4 @davazp mklist function added.
authored
294
295 ;;; Return X if it is a list, (list X) otherwise.
296 (defun mklist (x)
297 (if (listp x)
298 x
299 (list x)))
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
300
301 ;;;; Streams
302 ;;; Read characters from STREAM until it finds a char of CHAR-BAG. If
303 ;;; it finds a NON-EXPECT character, it signals an error. If an end of
304 ;;; file condition is signaled and EOF-ERROR-P is nil, return nil.
305 (defun read-until (stream char-bag &optional (not-expect "") (eof-error-p t))
306 (flet (;; Check if CH is a terminal char
307 (terminal-char-p (ch)
308 (etypecase char-bag
309 (character (char= ch char-bag))
310 (sequence (find ch char-bag :test #'char=))
311 (function (funcall char-bag ch))))
312 ;; Check if CH is not an expected char
313 (not-expect-char-p (ch)
314 (etypecase not-expect
315 (character (char= ch not-expect))
316 (sequence (find ch not-expect :test #'char=))
317 (function (funcall not-expect ch)))))
318 ;; Read characters
319 (with-output-to-string (out)
320 (loop for ch = (peek-char nil stream eof-error-p)
321 until (and (not eof-error-p) (null ch))
322 until (terminal-char-p ch)
323 when (not-expect-char-p ch)
324 do (error "Character ~w is not expected." ch)
325 do (write-char (read-char stream) out)))))
326
327
328 ;;;; Comparators
329
bf500eb @davazp Fix typos.
authored
330 ;;; Like `char=' but it is case-insensitive.
4da92bd @davazp Revert last commit.
authored
331 (defun char-ci= (char1 char2)
1de8a7d @davazp Rewrite string-ci= to use char-ci=
authored
332 (declare (character char1 char2))
333 (char= (char-upcase char1)
334 (char-upcase char2)))
335
41cb4d8 @davazp Function string-ci= added.
authored
336 ;;; Like `string=' but it is case-insensitive.
4da92bd @davazp Revert last commit.
authored
337 (defun string-ci= (str1 str2)
338 (declare (string str1 str2))
7d7ce50 @davazp Recur advances and boolean unit tests added.
authored
339 (and (= (length str1) (length str2))
340 (every #'char-ci= str1 str2)))
41cb4d8 @davazp Function string-ci= added.
authored
341
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
342 ;;; Check if X and Y are not eq.
343 (definline neq (x y)
344 (not (eq x y)))
10e46ed @davazp define-predicate-type macro added.
authored
345
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
346 ;;; Anaphoric IF.
347 (defmacro aif (condition then &optional else)
348 `(let ((it ,condition))
349 (if it ,then ,else)))
350
351
6cc8d13 @davazp More refactoring.
authored
352 ;;;; setf-based
353
a894ca2 @davazp multiple-setf macro and generalization of zerof and nilf.
authored
354 ;;; The multiple-setf macro was written by Mario Castelán. It is a
355 ;;; beautiful form to support multiple places in zerof and nilf.
356 (defmacro multiple-setf (value &rest places)
5ee658b @davazp multiple-setf rewritten with once-only.
authored
357 (once-only (value)
358 `(setf ,@(loop for place in places
e21d952 @davazp Crap, I fix a stupid mistake from previous commit.
authored
359 append `(,place ,value)))))
a894ca2 @davazp multiple-setf macro and generalization of zerof and nilf.
authored
360
361 ;;; Set PLACES to 0
362 (defmacro zerof (&rest places)
363 `(multiple-setf 0 ,@places))
6cc8d13 @davazp More refactoring.
authored
364
365 ;;; Set PLACE to nil.
a894ca2 @davazp multiple-setf macro and generalization of zerof and nilf.
authored
366 (defmacro nilf (&rest places)
367 `(multiple-setf nil ,@places))
6cc8d13 @davazp More refactoring.
authored
368
369 ;;; (modf place N) set place to (mod place N)
370 (define-modify-macro modf (n) mod)
371
372
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
373 ;;;; Others
374
375 ;;; Like `parse-integer' but it is not allowed to have a sign (+\-).
d52f6bc @davazp Fix bug in parse-unsigned-integer.
authored
376 (defun parse-unsigned-integer (string &rest keyargs &key (start 0) end &allow-other-keys)
377 (unless (or (eql start end) (digit-char-p (elt string start)))
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
378 (error "~w is not an unsigned integer." string))
379 (apply #'parse-integer string keyargs))
380
381 ;;; Integer division
382 (definline idiv (a b)
383 (declare (integer a b)
384 (optimize speed))
385 (values (truncate a b)))
386
387 ;;; Check if N divides to M.
388 (definline divisiblep (m n)
5cfcc54 @davazp rcurry added.
authored
389 (declare (fixnum m n) (optimize speed))
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
390 (zerop (mod m n)))
10e46ed @davazp define-predicate-type macro added.
authored
391
27ca462 utils.lisp restructuration.
Mario Castelan Castro authored
392 ;;; Set PLACE to zero.
87c8934 @davazp Bug fix in %do-sequence. More documenumentation. Indentation
authored
393 ;;; This function is thought to use this function as default-value in
394 ;;; optional or keyword arguments.
395 (defun required-arg ()
396 (error "A required &KEY or &OPTIONAL argument was not supplied."))
397
6e96c8b @davazp Recur data type implementation finished, though it is not tested yet.
authored
398 (defmacro /debug1 (form)
e8c5ff2 @davazp New /debug macro, and use in recur data type.
authored
399 (with-gensyms (value)
400 `(progn
401 (let ((,value ,form))
402 (format *error-output* "~%; DEBUG~@[ (~a)~]"
403 (load-time-value (aif *load-pathname* (enough-namestring it))))
404 (pprint ',form *error-output*)
405 (write-string " ===> " *error-output*)
406 (princ ,value *error-output*)
407 (terpri *error-output*)
6e96c8b @davazp Recur data type implementation finished, though it is not tested yet.
authored
408 ,value))))
409
410 ;;; Run CODE and print information about the evaluation of
411 ;;; CODE. Useful for debugging.
412 (defmacro /debug (&body code)
413 `(progn
414 ,@(loop for form in code collect `(/debug1 ,form))))
415
e8c5ff2 @davazp New /debug macro, and use in recur data type.
authored
416
3bb8b25 @davazp Date and time related functions works better between types.
authored
417 (definline mod7 (n)
418 (declare (optimize speed))
419 (declare (fixnum n))
420 (mod n 7))
6cc8d13 @davazp More refactoring.
authored
421
6e96c8b @davazp Recur data type implementation finished, though it is not tested yet.
authored
422 (defmacro implyp (p q)
423 `(if ,p
424 (and ,q t)
425 t))
426
427 (defun range (m n &optional (step 1))
428 (loop for i from m to n by step collect i))
429
430 (defun curry (fn &rest preargs)
431 (lambda (&rest postargs)
432 (apply fn (append preargs postargs))))
433
5cfcc54 @davazp rcurry added.
authored
434 (defun rcurry (fn &rest postargs)
435 (lambda (&rest preargs)
436 (apply fn (append preargs postargs))))
437
2e1bf4d @davazp CLOS compatiblity layer draft. It needs work yet.
authored
438 ;;; Check if CLASS1 is a superclass of CLASS2.
439 (defun superclassp (class1 class2)
440 (subclassp class2 class1))
441
442
4d2defd @davazp Move utilities to utils.lisp
authored
443 ;;; utils.lisp ends here
Something went wrong with that request. Please try again.