Coverage report: /home/jsnell/.sbcl/site/cl-ppcre-1.2.13/util.lisp

KindCoveredAll%
expression200261 76.6
branch2634 76.5
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
2
 ;;; $Header: /usr/local/cvsrep/cl-ppcre/util.lisp,v 1.32 2005/08/23 10:32:30 edi Exp $
3
 
4
 ;;; Utility functions and constants dealing with the hash-tables
5
 ;;; we use to encode character classes
6
 
7
 ;;; Hash-tables are treated like sets, i.e. a character C is a member of the
8
 ;;; hash-table H iff (GETHASH C H) is true.
9
 
10
 ;;; Copyright (c) 2002-2005, Dr. Edmund Weitz. All rights reserved.
11
 
12
 ;;; Redistribution and use in source and binary forms, with or without
13
 ;;; modification, are permitted provided that the following conditions
14
 ;;; are met:
15
 
16
 ;;;   * Redistributions of source code must retain the above copyright
17
 ;;;     notice, this list of conditions and the following disclaimer.
18
 
19
 ;;;   * Redistributions in binary form must reproduce the above
20
 ;;;     copyright notice, this list of conditions and the following
21
 ;;;     disclaimer in the documentation and/or other materials
22
 ;;;     provided with the distribution.
23
 
24
 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
25
 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
26
 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
27
 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
28
 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
29
 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
30
 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
31
 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
32
 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
33
 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
34
 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
35
 
36
 (in-package #:cl-ppcre)
37
 
38
 #+:lispworks
39
 (import 'lw:with-unique-names)
40
 
41
 #-:lispworks
42
 (defmacro with-unique-names ((&rest bindings) &body body)
43
   "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*
44
 
45
 Executes a series of forms with each VAR bound to a fresh,
46
 uninterned symbol. The uninterned symbol is as if returned by a call
47
 to GENSYM with the string denoted by X - or, if X is not supplied, the
48
 string denoted by VAR - as argument.
49
 
50
 The variable bindings created are lexical unless special declarations
51
 are specified. The scopes of the name bindings and declarations do not
52
 include the Xs.
53
 
54
 The forms are evaluated in order, and the values of all but the last
55
 are discarded \(that is, the body is an implicit PROGN)."
56
   ;; reference implementation posted to comp.lang.lisp as
57
   ;; <cy3bshuf30f.fsf@ljosa.com> by Vebjorn Ljosa - see also
58
   ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
59
   `(let ,(mapcar #'(lambda (binding)
60
                      (check-type binding (or cons symbol))
61
                      (if (consp binding)
62
                        (destructuring-bind (var x) binding
63
                          (check-type var symbol)
64
                          `(,var (gensym ,(etypecase x
65
                                           (symbol (symbol-name x))
66
                                           (character (string x))
67
                                           (string x)))))
68
                        `(,binding (gensym ,(symbol-name binding)))))
69
                  bindings)
70
          ,@body))
71
 
72
 #+:lispworks
73
 (eval-when (:compile-toplevel :load-toplevel :execute)
74
   (setf (macro-function 'with-rebinding)
75
           (macro-function 'lw:rebinding)))
76
 
77
 #-:lispworks
78
 (defmacro with-rebinding (bindings &body body)
79
   "WITH-REBINDING ( { var | (var prefix) }* ) form*
80
 
81
 Evaluates a series of forms in the lexical environment that is
82
 formed by adding the binding of each VAR to a fresh, uninterned
83
 symbol, and the binding of that fresh, uninterned symbol to VAR's
84
 original value, i.e., its value in the current lexical environment.
85
 
86
 The uninterned symbol is created as if by a call to GENSYM with the
87
 string denoted by PREFIX - or, if PREFIX is not supplied, the string
88
 denoted by VAR - as argument.
89
 
90
 The forms are evaluated in order, and the values of all but the last
91
 are discarded \(that is, the body is an implicit PROGN)."
92
   ;; reference implementation posted to comp.lang.lisp as
93
   ;; <cy3wv0fya0p.fsf@ljosa.com> by Vebjorn Ljosa - see also
94
   ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
95
   (loop for binding in bindings
96
         for var = (if (consp binding) (car binding) binding)
97
         for name = (gensym)
98
         collect `(,name ,var) into renames
99
         collect ``(,,var ,,name) into temps
100
         finally (return `(let ,renames
101
                           (with-unique-names ,bindings
102
                             `(let (,,@temps)
103
                               ,,@body))))))
104
 
105
 (eval-when (:compile-toplevel :execute :load-toplevel)
106
   (defvar *regex-char-code-limit* char-code-limit
107
     "The upper exclusive bound on the char-codes of characters which
108
 can occur in character classes.  Change this value BEFORE creating
109
 scanners if you don't need the Unicode support of implementations like
110
 AllegroCL, CLISP, LispWorks, or SBCL.")
111
   (declaim (type fixnum *regex-char-code-limit*))
112
 
113
   (defun make-char-hash (test)
114
     (declare #.*special-optimize-settings*)
115
     "Returns a hash-table of all characters satisfying test."
116
     (loop with hash = (make-hash-table)
117
           for c of-type fixnum from 0 below char-code-limit
118
           for chr = (code-char c)
119
           if (and chr (funcall test chr))
120
             do (setf (gethash chr hash) t)
121
           finally (return hash)))
122
 
123
   (declaim (inline word-char-p))
124
 
125
   (defun word-char-p (chr)
126
     (declare #.*standard-optimize-settings*)
127
     "Tests whether a character is a \"word\" character.
128
 In the ASCII charset this is equivalent to a-z, A-Z, 0-9, or _,
129
 i.e. the same as Perl's [\\w]."
130
     (or (alphanumericp chr)
131
         (char= chr #\_)))
132
 
133
   (unless (boundp '+whitespace-char-string+)
134
     (defconstant +whitespace-char-string+
135
       (coerce
136
        '(#\Space #\Tab #\Linefeed #\Return #\Page)
137
        'string)
138
       "A string of all characters which are considered to be whitespace.
139
 Same as Perl's [\\s]."))
140
 
141
   (defun whitespacep (chr)
142
     (declare #.*special-optimize-settings*)
143
     "Tests whether a character is whitespace,
144
 i.e. whether it would match [\\s] in Perl."
145
     (find chr +whitespace-char-string+ :test #'char=)))
146
 
147
 ;; the following DEFCONSTANT statements are wrapped with
148
 ;; (UNLESS (BOUNDP ...) ...) to make SBCL happy
149
 
150
 (unless (boundp '+digit-hash+)
151
   (defconstant +digit-hash+
152
     (make-char-hash (lambda (chr) (char<= #\0 chr #\9)))
153
     "Hash-table containing the digits from 0 to 9."))
154
 
155
 (unless (boundp '+word-char-hash+)
156
   (defconstant +word-char-hash+
157
     (make-char-hash #'word-char-p)
158
     "Hash-table containing all \"word\" characters."))
159
 
160
 (unless (boundp '+whitespace-char-hash+)
161
   (defconstant +whitespace-char-hash+
162
     (make-char-hash #'whitespacep)
163
     "Hash-table containing all whitespace characters."))
164
 
165
 (defun merge-hash (hash1 hash2)
166
   (declare #.*standard-optimize-settings*)
167
   "Returns the \"sum\" of two hashes. This is a destructive operation
168
 on HASH1."
169
   (cond ((> (hash-table-count hash2)
170
             *regex-char-code-limit*)
171
           ;; don't walk through, e.g., the whole +WORD-CHAR-HASH+ if
172
           ;; the user has set *REGEX-CHAR-CODE-LIMIT* to a lower value
173
           (loop for c of-type fixnum from 0 below *regex-char-code-limit*
174
                 for chr = (code-char c)
175
                 if (and chr (gethash chr hash2))
176
                 do (setf (gethash chr hash1) t)))
177
         (t
178
           (loop for chr being the hash-keys of hash2
179
                 do (setf (gethash chr hash1) t))))
180
   hash1)
181
 
182
 (defun merge-inverted-hash (hash1 hash2)
183
   (declare #.*standard-optimize-settings*)
184
   "Returns the \"sum\" of HASH1 and the \"inverse\" of HASH2. This is
185
 a destructive operation on HASH1."
186
   (loop for c of-type fixnum from 0 below *regex-char-code-limit*
187
         for chr = (code-char c)
188
         if (and chr (not (gethash chr hash2)))
189
           do (setf (gethash chr hash1) t))
190
   hash1)
191
 
192
 (defun create-ranges-from-hash (hash &key downcasep)
193
   (declare #.*standard-optimize-settings*)
194
   "Tries to identify up to three intervals (with respect to CHAR<)
195
 which together comprise HASH. Returns NIL if this is not possible.
196
 If DOWNCASEP is true it will treat the hash-table as if it represents
197
 both the lower-case and the upper-case variants of its members and
198
 will only return the respective lower-case intervals."
199
   ;; discard empty hash-tables
200
   (unless (and hash (plusp (hash-table-count hash)))
201
     (return-from create-ranges-from-hash nil))
202
   (loop with min1 and min2 and min3
203
         and max1 and max2 and max3
204
         ;; loop through all characters in HASH, sorted by CHAR<
205
         for chr in (sort (the list
206
                            (loop for chr being the hash-keys of hash
207
                                  collect (if downcasep
208
                                            (char-downcase chr)
209
                                            chr)))
210
                          #'char<)
211
         for code = (char-code chr)
212
         ;; MIN1, MAX1, etc. are _exclusive_
213
         ;; bounds of the intervals identified so far
214
         do (cond
215
              ((not min1)
216
                ;; this will only happen once, for the first character
217
                (setq min1 (1- code)
218
                      max1 (1+ code)))
219
              ((<= (the fixnum min1) code (the fixnum max1))
220
                ;; we're here as long as CHR fits into the first interval
221
                (setq min1 (min (the fixnum min1) (1- code))
222
                      max1 (max (the fixnum max1) (1+ code))))
223
              ((not min2)
224
                ;; we need to open a second interval
225
                ;; this'll also happen only once
226
                (setq min2 (1- code)
227
                      max2 (1+ code)))
228
              ((<= (the fixnum min2) code (the fixnum max2))
229
                ;; CHR fits into the second interval
230
                (setq min2 (min (the fixnum min2) (1- code))
231
                      max2 (max (the fixnum max2) (1+ code))))
232
              ((not min3)
233
                ;; we need to open the third interval
234
                ;; happens only once
235
                (setq min3 (1- code)
236
                      max3 (1+ code)))
237
              ((<= (the fixnum min3) code (the fixnum max3))
238
                ;; CHR fits into the third interval
239
                (setq min3 (min (the fixnum min3) (1- code))
240
                      max3 (max (the fixnum max3) (1+ code))))
241
              (t
242
                ;; we're out of luck, CHR doesn't fit
243
                ;; into one of the three intervals
244
                (return nil)))
245
         ;; on success return all bounds
246
         ;; make them inclusive bounds before returning
247
         finally (return (values (code-char (1+ min1))
248
                                 (code-char (1- max1))
249
                                 (and min2 (code-char (1+ min2)))
250
                                 (and max2 (code-char (1- max2)))
251
                                 (and min3 (code-char (1+ min3)))
252
                                 (and max3 (code-char (1- max3)))))))
253
 
254
 (defmacro maybe-coerce-to-simple-string (string)
255
   (with-unique-names (=string=)
256
     `(let ((,=string= ,string))
257
       (cond ((simple-string-p ,=string=)
258
               ,=string=)
259
             (t
260
               (coerce ,=string= 'simple-string))))))
261
 
262
 (declaim (inline nsubseq))
263
 (defun nsubseq (sequence start &optional (end (length sequence)))
264
   "Return a subsequence by pointing to location in original sequence."
265
   (make-array (- end start)
266
               :element-type (array-element-type sequence)
267
               :displaced-to sequence
268
               :displaced-index-offset start))
269
 
270
 (defun normalize-var-list (var-list)
271
   "Utility function for REGISTER-GROUPS-BIND and
272
 DO-REGISTER-GROUPS. Creates the long form \(a list of \(FUNCTION VAR)
273
 entries) out of the short form of VAR-LIST."
274
   (loop for element in var-list
275
         if (consp element)
276
           nconc (loop for var in (rest element)
277
                       collect (list (first element) var))
278
         else
279
           collect (list '(function identity) element)))
280
 
281
 (defun string-list-to-simple-string (string-list)
282
   (declare #.*standard-optimize-settings*)
283
   "Concatenates a list of strings to one simple-string."
284
   ;; this function provided by JP Massar; note that we can't use APPLY
285
   ;; with CONCATENATE here because of CALL-ARGUMENTS-LIMIT
286
   (let ((total-size 0))
287
     (declare (type fixnum total-size))
288
     (dolist (string string-list)
289
       #-genera (declare (type string string))
290
       (incf total-size (length string)))
291
     (let ((result-string (make-sequence 'simple-string total-size))
292
           (curr-pos 0))
293
       (declare (type fixnum curr-pos))
294
       (dolist (string string-list)
295
         #-genera (declare (type string string))
296
         (replace result-string string :start1 curr-pos)
297
         (incf curr-pos (length string)))
298
       result-string)))