Coverage report: /home/ellis/comp/ext/cl-ppcre/charmap.lisp

KindCoveredAll%
expression0146 0.0
branch044 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; $Header: /usr/local/cvsrep/cl-ppcre/charmap.lisp,v 1.19 2009/09/17 19:17:30 edi Exp $
2
 
3
 ;;; An optimized representation of sets of characters.
4
 
5
 ;;; Copyright (c) 2008-2009, Dr. Edmund Weitz. All rights reserved.
6
 
7
 ;;; Redistribution and use in source and binary forms, with or without
8
 ;;; modification, are permitted provided that the following conditions
9
 ;;; are met:
10
 
11
 ;;;   * Redistributions of source code must retain the above copyright
12
 ;;;     notice, this list of conditions and the following disclaimer.
13
 
14
 ;;;   * Redistributions in binary form must reproduce the above
15
 ;;;     copyright notice, this list of conditions and the following
16
 ;;;     disclaimer in the documentation and/or other materials
17
 ;;;     provided with the distribution.
18
 
19
 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
20
 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
21
 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
22
 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
23
 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
24
 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
25
 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
26
 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
27
 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
28
 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
29
 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30
 
31
 (in-package :cl-ppcre)
32
 
33
 (defstruct (charmap  (:constructor make-charmap%))
34
   ;; a bit vector mapping char codes to "booleans" (1 for set members,
35
   ;; 0 for others)
36
   (vector #*0 :type simple-bit-vector)
37
   ;; the smallest character code of all characters in the set
38
   (start 0 :type fixnum)
39
   ;; the upper (exclusive) bound of all character codes in the set
40
   (end 0 :type fixnum)
41
   ;; the number of characters in the set, or NIL if this is unknown
42
   (count nil :type (or fixnum null))
43
   ;; whether the charmap actually represents the complement of the set  
44
   (complementp nil :type boolean))
45
 
46
 ;; seems to be necessary for some Lisps like ClozureCL
47
 (defmethod make-load-form ((map charmap) &optional environment)
48
   (make-load-form-saving-slots map :environment environment))
49
 
50
 (declaim (inline in-charmap-p))
51
 (defun in-charmap-p (char charmap)
52
   "Tests whether the character CHAR belongs to the set represented by CHARMAP."
53
   (declare #.*standard-optimize-settings*)
54
   (declare (character char) (charmap charmap))
55
   (let* ((char-code (char-code char))
56
          (char-in-vector-p
57
           (let ((charmap-start (charmap-start charmap)))
58
             (declare (fixnum charmap-start))
59
             (and (<= charmap-start char-code)
60
                  (< char-code (the fixnum (charmap-end charmap)))
61
                  (= 1 (sbit (the simple-bit-vector (charmap-vector charmap))
62
                             (- char-code charmap-start)))))))
63
     (cond ((charmap-complementp charmap) (not char-in-vector-p))
64
           (t char-in-vector-p))))
65
 
66
 (defun charmap-contents (charmap)
67
   "Returns a list of all characters belonging to a character map.
68
 Only works for non-complement charmaps."
69
   (declare #.*standard-optimize-settings*)
70
   (declare (charmap charmap))
71
   (and (not (charmap-complementp charmap))
72
        (loop for code of-type fixnum from (charmap-start charmap) to (charmap-end charmap)
73
              for i across (the simple-bit-vector (charmap-vector charmap))
74
              when (= i 1)
75
              collect (code-char code))))
76
 
77
 (defun make-charmap (start end test-function &optional complementp)
78
   "Creates and returns a charmap representing all characters with
79
 character codes in the interval [start end) that satisfy
80
 TEST-FUNCTION.  The COMPLEMENTP slot of the charmap is set to the
81
 value of the optional argument, but this argument doesn't have an
82
 effect on how TEST-FUNCTION is used."
83
   (declare #.*standard-optimize-settings*)
84
   (declare (fixnum start end))
85
   (let ((vector (make-array (- end start) :element-type 'bit))
86
         (count 0))
87
     (declare (fixnum count))
88
     (loop for code from start below end
89
           for char = (code-char code)
90
           for index from 0
91
           when char do
92
           (incf count)
93
           (setf (sbit vector index) (if (funcall test-function char) 1 0)))
94
     (make-charmap% :vector vector
95
                    :start start
96
                    :end end
97
                    ;; we don't know for sure if COMPLEMENTP is true as
98
                    ;; there isn't a necessary a character for each
99
                    ;; integer below *REGEX-CHAR-CODE-LIMIT*
100
                    :count (and (not complementp) count)
101
                    ;; make sure it's boolean
102
                    :complementp (not (not complementp)))))
103
 
104
 (defun create-charmap-from-test-function (test-function start end)
105
   "Creates and returns a charmap representing all characters with
106
 character codes between START and END which satisfy TEST-FUNCTION.
107
 Tries to find the smallest interval which is necessary to represent
108
 the character set and uses the complement representation if that
109
 helps."
110
   (declare #.*standard-optimize-settings*)
111
   (let (start-in end-in start-out end-out)
112
     ;; determine the smallest intervals containing the set and its
113
     ;; complement, [start-in, end-in) and [start-out, end-out) - first
114
     ;; the lower bound
115
     (loop for code from start below end
116
           for char = (code-char code)
117
           until (and start-in start-out)
118
           when (and char
119
                     (not start-in)
120
                     (funcall test-function char))
121
           do (setq start-in code)
122
           when (and char
123
                     (not start-out)
124
                     (not (funcall test-function char)))
125
           do (setq start-out code))
126
     (unless start-in
127
       ;; no character satisfied the test, so return a "pseudo" charmap
128
       ;; where IN-CHARMAP-P is always false
129
       (return-from create-charmap-from-test-function
130
         (make-charmap% :count 0)))
131
     (unless start-out
132
       ;; no character failed the test, so return a "pseudo" charmap
133
       ;; where IN-CHARMAP-P is always true
134
       (return-from create-charmap-from-test-function
135
         (make-charmap% :complementp t)))
136
     ;; now determine upper bound
137
     (loop for code from (1- end) downto start
138
           for char = (code-char code)
139
           until (and end-in end-out)
140
           when (and char
141
                     (not end-in)
142
                     (funcall test-function char))
143
           do (setq end-in (1+ code))
144
           when (and char
145
                     (not end-out)
146
                     (not (funcall test-function char)))
147
           do (setq end-out (1+ code)))
148
     ;; use the smaller interval
149
     (cond ((<= (- end-in start-in) (- end-out start-out))
150
            (make-charmap start-in end-in test-function))
151
           (t (make-charmap start-out end-out (complement* test-function) t)))))