clucumber 0.1.1 → 0.2.0
Sign up to get free protection for your applications and to get access to all the features.
- data/LICENSE +1 -1
- data/README.md +4 -9
- data/lib/clucumber/clucumber-bootstrap.lisp +32 -0
- data/lib/clucumber/vendor/cl-interpol/alias.lisp +55 -0
- data/lib/clucumber/vendor/cl-interpol/cl-interpol.asd +56 -0
- data/lib/clucumber/vendor/cl-interpol/load.lisp +53 -0
- data/lib/clucumber/vendor/cl-interpol/packages.lisp +40 -0
- data/lib/clucumber/vendor/cl-interpol/read.lisp +716 -0
- data/lib/clucumber/vendor/cl-interpol/specials.lisp +113 -0
- data/lib/clucumber/vendor/cl-interpol/test/packages.lisp +34 -0
- data/lib/clucumber/vendor/cl-interpol/test/tests.lisp +128 -0
- data/lib/clucumber/vendor/cl-interpol/test.lisp +177 -0
- data/lib/clucumber/vendor/cl-interpol/test2.lisp +6254 -0
- data/lib/clucumber/vendor/cl-interpol/unicode.lisp +13912 -0
- data/lib/clucumber/vendor/cl-interpol/util.lisp +122 -0
- data/lib/clucumber/vendor/cl-ppcre/api.lisp +1262 -0
- data/lib/clucumber/vendor/cl-ppcre/charmap.lisp +152 -0
- data/lib/clucumber/vendor/cl-ppcre/charset.lisp +242 -0
- data/lib/clucumber/vendor/cl-ppcre/chartest.lisp +98 -0
- data/lib/clucumber/vendor/cl-ppcre/cl-ppcre-test.asd +34 -0
- data/lib/clucumber/vendor/cl-ppcre/cl-ppcre-unicode/packages.lisp +38 -0
- data/lib/clucumber/vendor/cl-ppcre/cl-ppcre-unicode/resolver.lisp +61 -0
- data/lib/clucumber/vendor/cl-ppcre/cl-ppcre-unicode.asd +58 -0
- data/lib/clucumber/vendor/cl-ppcre/cl-ppcre.asd +79 -0
- data/lib/clucumber/vendor/cl-ppcre/closures.lisp +471 -0
- data/lib/clucumber/vendor/cl-ppcre/convert.lisp +875 -0
- data/lib/clucumber/vendor/cl-ppcre/errors.lisp +84 -0
- data/lib/clucumber/vendor/cl-ppcre/lexer.lisp +737 -0
- data/lib/clucumber/vendor/cl-ppcre/lispworks-defsystem.lisp +57 -0
- data/lib/clucumber/vendor/cl-ppcre/load.lisp +67 -0
- data/lib/clucumber/vendor/cl-ppcre/optimize.lisp +578 -0
- data/lib/clucumber/vendor/cl-ppcre/packages.lisp +68 -0
- data/lib/clucumber/vendor/cl-ppcre/parser.lisp +319 -0
- data/lib/clucumber/vendor/cl-ppcre/ppcre-tests.lisp +269 -0
- data/lib/clucumber/vendor/cl-ppcre/regex-class-util.lisp +555 -0
- data/lib/clucumber/vendor/cl-ppcre/regex-class.lisp +259 -0
- data/lib/clucumber/vendor/cl-ppcre/repetition-closures.lisp +833 -0
- data/lib/clucumber/vendor/cl-ppcre/scanner.lisp +506 -0
- data/lib/clucumber/vendor/cl-ppcre/specials.lisp +172 -0
- data/lib/clucumber/vendor/cl-ppcre/test/packages.lisp +37 -0
- data/lib/clucumber/vendor/cl-ppcre/test/perl-tests.lisp +150 -0
- data/lib/clucumber/vendor/cl-ppcre/test/tests.lisp +159 -0
- data/lib/clucumber/vendor/cl-ppcre/test/unicode-tests.lisp +80 -0
- data/lib/clucumber/vendor/cl-ppcre/util.lisp +201 -0
- data/lib/clucumber/vendor/cl-unicode/alias.lisp +135 -0
- data/lib/clucumber/vendor/cl-unicode/api.lisp +412 -0
- data/lib/clucumber/vendor/cl-unicode/build/char-info.lisp +133 -0
- data/lib/clucumber/vendor/cl-unicode/build/dump.lisp +239 -0
- data/lib/clucumber/vendor/cl-unicode/build/read.lisp +280 -0
- data/lib/clucumber/vendor/cl-unicode/build/util.lisp +182 -0
- data/lib/clucumber/vendor/cl-unicode/cl-unicode.asd +90 -0
- data/lib/clucumber/vendor/cl-unicode/conditions.lisp +54 -0
- data/lib/clucumber/vendor/cl-unicode/derived.lisp +120 -0
- data/lib/clucumber/vendor/cl-unicode/hash-tables.lisp +20 -0
- data/lib/clucumber/vendor/cl-unicode/lists.lisp +10 -0
- data/lib/clucumber/vendor/cl-unicode/methods.lisp +15 -0
- data/lib/clucumber/vendor/cl-unicode/packages.lisp +76 -0
- data/lib/clucumber/vendor/cl-unicode/specials.lisp +135 -0
- data/lib/clucumber/vendor/cl-unicode/test/packages.lisp +34 -0
- data/lib/clucumber/vendor/cl-unicode/test/tests.lisp +150 -0
- data/lib/clucumber/vendor/cl-unicode/test-functions.lisp +94 -0
- data/lib/clucumber/vendor/cl-unicode/util.lisp +274 -0
- data/lib/clucumber/vendor/lift/compare/fiveam-tests.lisp +14 -0
- data/lib/clucumber/vendor/lift/compare/lift-tests.lisp +13 -0
- data/lib/clucumber/vendor/lift/compare/rt-tests.lisp +16 -0
- data/lib/clucumber/vendor/lift/compare/xlunit-tests.lisp +15 -0
- data/lib/clucumber/vendor/lift/dev/changes.lisp +61 -0
- data/lib/clucumber/vendor/lift/dev/config.lisp +354 -0
- data/lib/clucumber/vendor/lift/dev/copy-file.lisp +117 -0
- data/lib/clucumber/vendor/lift/dev/introspection.lisp +232 -0
- data/lib/clucumber/vendor/lift/dev/lift-interface.lisp +56 -0
- data/lib/clucumber/vendor/lift/dev/lift-notes.lisp +202 -0
- data/lib/clucumber/vendor/lift/dev/lift-randomized.lisp +45 -0
- data/lib/clucumber/vendor/lift/dev/lift.lisp +2383 -0
- data/lib/clucumber/vendor/lift/dev/macros.lisp +229 -0
- data/lib/clucumber/vendor/lift/dev/measuring.lisp +156 -0
- data/lib/clucumber/vendor/lift/dev/packages.lisp +161 -0
- data/lib/clucumber/vendor/lift/dev/port.lisp +151 -0
- data/lib/clucumber/vendor/lift/dev/prototypes.lisp +282 -0
- data/lib/clucumber/vendor/lift/dev/random-testing.lisp +124 -0
- data/lib/clucumber/vendor/lift/dev/report-locations.lisp +13 -0
- data/lib/clucumber/vendor/lift/dev/reports.lisp +916 -0
- data/lib/clucumber/vendor/lift/dev/utilities.lisp +242 -0
- data/lib/clucumber/vendor/lift/docs/package.lisp +6 -0
- data/lib/clucumber/vendor/lift/docs/setup.lisp +17 -0
- data/lib/clucumber/vendor/lift/examples/basic-examples.lisp +289 -0
- data/lib/clucumber/vendor/lift/examples/random-testing.lisp +32 -0
- data/lib/clucumber/vendor/lift/lift-documentation.asd +28 -0
- data/lib/clucumber/vendor/lift/lift-test.asd +35 -0
- data/lib/clucumber/vendor/lift/lift.asd +77 -0
- data/lib/clucumber/vendor/lift/test/equality-tests.lisp +40 -0
- data/lib/clucumber/vendor/lift/test/finding-tests.lisp +32 -0
- data/lib/clucumber/vendor/lift/test/lift-test.lisp +783 -0
- data/lib/clucumber/vendor/lift/test/order-of-operations.lisp +54 -0
- data/lib/clucumber/vendor/lift/test/packages.lisp +17 -0
- data/lib/clucumber/vendor/lift/test/test-config-files.lisp +20 -0
- data/lib/clucumber/vendor/lift/test/test-dynamic-variables.lisp +57 -0
- data/lib/clucumber/vendor/lift/test/test-maximum-problems.lisp +74 -0
- data/lib/clucumber/vendor/lift/test/test-prototypes.lisp +278 -0
- data/lib/clucumber/vendor/lift/test/test-timeout.lisp +37 -0
- data/lib/clucumber/vendor/lift/test/tests-in-progress.lisp +62 -0
- data/lib/clucumber/vendor/lift/test/testsuite-expects.lisp +60 -0
- data/lib/clucumber/vendor/lift/timeout/package.lisp +13 -0
- data/lib/clucumber/vendor/lift/timeout/with-timeout.lisp +123 -0
- data/lib/clucumber/vendor/lift/website/stuff/Temp.lisp +34 -0
- data/lib/clucumber/vendor/st-json/st-json.asd +3 -0
- data/lib/clucumber/vendor/st-json/st-json.lisp +310 -0
- data/lib/clucumber/vendor/trivial-backtrace/dev/backtrace.lisp +127 -0
- data/lib/clucumber/vendor/trivial-backtrace/dev/fallback.lisp +10 -0
- data/lib/clucumber/vendor/trivial-backtrace/dev/map-backtrace.lisp +103 -0
- data/lib/clucumber/vendor/trivial-backtrace/dev/mucking.lisp +75 -0
- data/lib/clucumber/vendor/trivial-backtrace/dev/packages.lisp +13 -0
- data/lib/clucumber/vendor/trivial-backtrace/dev/utilities.lisp +104 -0
- data/lib/clucumber/vendor/trivial-backtrace/test/packages.lisp +5 -0
- data/lib/clucumber/vendor/trivial-backtrace/test/test-setup.lisp +4 -0
- data/lib/clucumber/vendor/trivial-backtrace/test/tests.lisp +16 -0
- data/lib/clucumber/vendor/trivial-backtrace/trivial-backtrace-test.asd +22 -0
- data/lib/clucumber/vendor/trivial-backtrace/trivial-backtrace.asd +35 -0
- data/lib/clucumber/vendor/usocket/backend/allegro.lisp +199 -0
- data/lib/clucumber/vendor/usocket/backend/armedbear.lisp +491 -0
- data/lib/clucumber/vendor/usocket/backend/clisp.lisp +260 -0
- data/lib/clucumber/vendor/usocket/backend/cmucl.lisp +266 -0
- data/lib/clucumber/vendor/usocket/backend/lispworks.lisp +741 -0
- data/lib/clucumber/vendor/usocket/backend/mcl.lisp +369 -0
- data/lib/clucumber/vendor/usocket/backend/openmcl.lisp +206 -0
- data/lib/clucumber/vendor/usocket/backend/sbcl.lisp +424 -0
- data/lib/clucumber/vendor/usocket/backend/scl.lisp +261 -0
- data/lib/clucumber/vendor/usocket/condition.lisp +227 -0
- data/lib/clucumber/vendor/usocket/package.lisp +82 -0
- data/lib/clucumber/vendor/usocket/server.lisp +45 -0
- data/lib/clucumber/vendor/usocket/test/package.lisp +13 -0
- data/lib/clucumber/vendor/usocket/test/test-usocket.lisp +166 -0
- data/lib/clucumber/vendor/usocket/usocket-test.asd +26 -0
- data/lib/clucumber/vendor/usocket/usocket.asd +37 -0
- data/lib/clucumber/vendor/usocket/usocket.lisp +542 -0
- data/lib/clucumber/vendor/usocket/vendor/kqueue.lisp +1 -0
- data/lib/clucumber/vendor/usocket/vendor/split-sequence.lisp +245 -0
- data/lib/clucumber.rb +29 -7
- metadata +151 -5
@@ -0,0 +1,37 @@
|
|
1
|
+
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
2
|
+
;;; $Header: /usr/local/cvsrep/cl-ppcre/test/packages.lisp,v 1.4 2009/09/17 19:17:36 edi Exp $
|
3
|
+
|
4
|
+
;;; Copyright (c) 2002-2009, Dr. Edmund Weitz. All rights reserved.
|
5
|
+
|
6
|
+
;;; Redistribution and use in source and binary forms, with or without
|
7
|
+
;;; modification, are permitted provided that the following conditions
|
8
|
+
;;; are met:
|
9
|
+
|
10
|
+
;;; * Redistributions of source code must retain the above copyright
|
11
|
+
;;; notice, this list of conditions and the following disclaimer.
|
12
|
+
|
13
|
+
;;; * Redistributions in binary form must reproduce the above
|
14
|
+
;;; copyright notice, this list of conditions and the following
|
15
|
+
;;; disclaimer in the documentation and/or other materials
|
16
|
+
;;; provided with the distribution.
|
17
|
+
|
18
|
+
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
19
|
+
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
20
|
+
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
21
|
+
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
22
|
+
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
23
|
+
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
24
|
+
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
25
|
+
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
26
|
+
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
27
|
+
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
28
|
+
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
29
|
+
|
30
|
+
(in-package :cl-user)
|
31
|
+
|
32
|
+
(defpackage :cl-ppcre-test
|
33
|
+
#+genera (:shadowing-import-from :common-lisp :lambda)
|
34
|
+
(:use #-:genera :cl #+:genera :future-common-lisp :cl-ppcre)
|
35
|
+
(:import-from :cl-ppcre :*standard-optimize-settings*
|
36
|
+
:string-list-to-simple-string)
|
37
|
+
(:export :run-all-tests :unicode-test))
|
@@ -0,0 +1,150 @@
|
|
1
|
+
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE-TEST; Base: 10 -*-
|
2
|
+
;;; $Header: /usr/local/cvsrep/cl-ppcre/test/perl-tests.lisp,v 1.8 2009/09/17 19:17:36 edi Exp $
|
3
|
+
|
4
|
+
;;; The tests in this file test CL-PPCRE against testdata generated by
|
5
|
+
;;; the Perl program `perltest.pl' from the input file `testinput' in
|
6
|
+
;;; order to check compatibility with Perl and correctness of the
|
7
|
+
;;; regex engine.
|
8
|
+
|
9
|
+
;;; Copyright (c) 2002-2009, Dr. Edmund Weitz. All rights reserved.
|
10
|
+
|
11
|
+
;;; Redistribution and use in source and binary forms, with or without
|
12
|
+
;;; modification, are permitted provided that the following conditions
|
13
|
+
;;; are met:
|
14
|
+
|
15
|
+
;;; * Redistributions of source code must retain the above copyright
|
16
|
+
;;; notice, this list of conditions and the following disclaimer.
|
17
|
+
|
18
|
+
;;; * Redistributions in binary form must reproduce the above
|
19
|
+
;;; copyright notice, this list of conditions and the following
|
20
|
+
;;; disclaimer in the documentation and/or other materials
|
21
|
+
;;; provided with the distribution.
|
22
|
+
|
23
|
+
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
24
|
+
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
25
|
+
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
26
|
+
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
27
|
+
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
28
|
+
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
29
|
+
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
30
|
+
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
31
|
+
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
32
|
+
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
33
|
+
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
34
|
+
|
35
|
+
(in-package :cl-ppcre-test)
|
36
|
+
|
37
|
+
(defvar *tests-to-skip* '(662 790 1439)
|
38
|
+
"Some tests we skip because the testdata is generated by a Perl
|
39
|
+
program and CL-PPCRE differs from Perl for these tests - on purpose.")
|
40
|
+
|
41
|
+
(defun create-string-from-input (input)
|
42
|
+
"Converts INPUT to a string which can be used in TEST below. The
|
43
|
+
input file `testdata' encodes strings containing non-printable
|
44
|
+
characters as lists where those characters are represented by their
|
45
|
+
character code."
|
46
|
+
(etypecase input
|
47
|
+
((or null string) input)
|
48
|
+
(list (string-list-to-simple-string
|
49
|
+
(loop for element in input
|
50
|
+
if (stringp element)
|
51
|
+
collect element
|
52
|
+
else
|
53
|
+
collect (string (code-char element)))))))
|
54
|
+
|
55
|
+
(defun perl-test (&key (file-name
|
56
|
+
(make-pathname :name "perltestdata"
|
57
|
+
:type nil :version nil
|
58
|
+
:defaults *this-file*)
|
59
|
+
file-name-provided-p)
|
60
|
+
(external-format '(:latin-1 :eol-style :lf))
|
61
|
+
verbose)
|
62
|
+
"Loops through all test cases in FILE-NAME and prints a report if
|
63
|
+
VERBOSE is true. EXTERNAL-FORMAT is the FLEXI-STREAMS external format
|
64
|
+
which is used to read the file. Returns a true value if all tests
|
65
|
+
succeeded.
|
66
|
+
|
67
|
+
For the syntax of the tests in FILE-NAME refer to the source code of
|
68
|
+
this function and to the Perl script perltest.pl which generates such
|
69
|
+
test files."
|
70
|
+
(declare #.*standard-optimize-settings*)
|
71
|
+
(with-open-file (binary-stream file-name :element-type 'flex:octet)
|
72
|
+
(let ((stream (flex:make-flexi-stream binary-stream :external-format external-format))
|
73
|
+
;; the standard Perl tests don't need full Unicode support
|
74
|
+
(*regex-char-code-limit* (if file-name-provided-p *regex-char-code-limit* 256))
|
75
|
+
;; we need this for the standard test suite or otherwise we
|
76
|
+
;; might get stack overflows
|
77
|
+
(*optimize-char-classes* (if file-name-provided-p *optimize-char-classes* :charmap))
|
78
|
+
;; we only check for correctness and don't care about speed
|
79
|
+
;; that match (but rather about space constraints of the
|
80
|
+
;; trial versions)
|
81
|
+
(*use-bmh-matchers* (if file-name-provided-p *use-bmh-matchers* nil))
|
82
|
+
;; some tests in the Perl suite explicitly check for this
|
83
|
+
(*allow-quoting* (if file-name-provided-p *allow-quoting* t)))
|
84
|
+
(do-tests ((format nil "Running tests in file ~S" (file-namestring file-name))
|
85
|
+
(not verbose))
|
86
|
+
(let ((input-line (or (read stream nil) (done)))
|
87
|
+
errors)
|
88
|
+
(destructuring-bind (counter
|
89
|
+
info-string%
|
90
|
+
regex%
|
91
|
+
case-insensitive-mode
|
92
|
+
multi-line-mode
|
93
|
+
single-line-mode
|
94
|
+
extended-mode
|
95
|
+
target%
|
96
|
+
perl-error
|
97
|
+
expected-result%
|
98
|
+
expected-registers)
|
99
|
+
input-line
|
100
|
+
(destructuring-bind (info-string regex target expected-result)
|
101
|
+
(mapcar 'create-string-from-input
|
102
|
+
(list info-string% regex% target% expected-result%))
|
103
|
+
(setq expected-registers (mapcar 'create-string-from-input expected-registers))
|
104
|
+
(unless (find counter *tests-to-skip* :test #'=)
|
105
|
+
(when verbose
|
106
|
+
(format t "~&~4D: ~S" counter info-string))
|
107
|
+
(let ((scanner
|
108
|
+
(handler-bind ((error (lambda (condition)
|
109
|
+
(declare (ignore condition))
|
110
|
+
(when perl-error
|
111
|
+
;; we expected an
|
112
|
+
;; error, so we can
|
113
|
+
;; signal success
|
114
|
+
(return-from test-block)))))
|
115
|
+
(create-scanner regex
|
116
|
+
:case-insensitive-mode case-insensitive-mode
|
117
|
+
:multi-line-mode multi-line-mode
|
118
|
+
:single-line-mode single-line-mode
|
119
|
+
:extended-mode extended-mode))))
|
120
|
+
(block test-block
|
121
|
+
(multiple-value-bind (start end reg-starts reg-ends)
|
122
|
+
(scan scanner target)
|
123
|
+
(cond (perl-error
|
124
|
+
(push (format nil "expected an error but got a result.")
|
125
|
+
errors))
|
126
|
+
(t
|
127
|
+
(when (not (eq start expected-result))
|
128
|
+
(if start
|
129
|
+
(let ((result (subseq target start end)))
|
130
|
+
(unless (string= result expected-result)
|
131
|
+
(push (format nil "expected ~S but got ~S."
|
132
|
+
expected-result result)
|
133
|
+
errors))
|
134
|
+
(setq reg-starts (coerce reg-starts 'list)
|
135
|
+
reg-ends (coerce reg-ends 'list))
|
136
|
+
(loop for i from 0
|
137
|
+
for expected-register in expected-registers
|
138
|
+
for reg-start = (nth i reg-starts)
|
139
|
+
for reg-end = (nth i reg-ends)
|
140
|
+
for register = (if (and reg-start reg-end)
|
141
|
+
(subseq target reg-start reg-end)
|
142
|
+
nil)
|
143
|
+
unless (string= expected-register register)
|
144
|
+
do (push (format nil "\\~A: expected ~S but got ~S."
|
145
|
+
(1+ i) expected-register register)
|
146
|
+
errors)))
|
147
|
+
(push (format nil "expected ~S but got ~S."
|
148
|
+
expected-result start)
|
149
|
+
errors))))))
|
150
|
+
errors))))))))))
|
@@ -0,0 +1,159 @@
|
|
1
|
+
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE-TEST; Base: 10 -*-
|
2
|
+
;;; $Header: /usr/local/cvsrep/cl-ppcre/test/tests.lisp,v 1.13 2009/09/17 19:17:36 edi Exp $
|
3
|
+
|
4
|
+
;;; The tests in this file test CL-PPCRE against testdata generated by
|
5
|
+
;;; the Perl program `perltest.pl' from the input file `testinput' in
|
6
|
+
;;; order to check compatibility with Perl and correctness of the
|
7
|
+
;;; regex engine.
|
8
|
+
|
9
|
+
;;; Copyright (c) 2002-2009, Dr. Edmund Weitz. All rights reserved.
|
10
|
+
|
11
|
+
;;; Redistribution and use in source and binary forms, with or without
|
12
|
+
;;; modification, are permitted provided that the following conditions
|
13
|
+
;;; are met:
|
14
|
+
|
15
|
+
;;; * Redistributions of source code must retain the above copyright
|
16
|
+
;;; notice, this list of conditions and the following disclaimer.
|
17
|
+
|
18
|
+
;;; * Redistributions in binary form must reproduce the above
|
19
|
+
;;; copyright notice, this list of conditions and the following
|
20
|
+
;;; disclaimer in the documentation and/or other materials
|
21
|
+
;;; provided with the distribution.
|
22
|
+
|
23
|
+
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
24
|
+
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
25
|
+
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
26
|
+
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
27
|
+
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
28
|
+
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
29
|
+
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
30
|
+
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
31
|
+
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
32
|
+
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
33
|
+
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
34
|
+
|
35
|
+
(in-package :cl-ppcre-test)
|
36
|
+
|
37
|
+
(defvar *this-file* (load-time-value
|
38
|
+
(or #.*compile-file-pathname* *load-pathname*))
|
39
|
+
"The location of this source file.")
|
40
|
+
|
41
|
+
(defmacro do-tests ((name &optional show-progress-p) &body body)
|
42
|
+
"Helper macro which repeatedly executes BODY until the code in body
|
43
|
+
calls the function DONE. It is assumed that each invocation of BODY
|
44
|
+
will be the execution of one test which returns NIL in case of success
|
45
|
+
and list of string describing errors otherwise.
|
46
|
+
|
47
|
+
The macro prints a simple progress indicator \(one dots for ten tests)
|
48
|
+
to *STANDARD-OUTPUT* unless SHOW-PROGRESS-P is NIL and returns a true
|
49
|
+
value iff all tests succeeded. Errors in BODY are caught and reported
|
50
|
+
\(and counted as failures)."
|
51
|
+
`(let ((successp t)
|
52
|
+
(testcount 1))
|
53
|
+
(block test-block
|
54
|
+
(flet ((done ()
|
55
|
+
(return-from test-block successp)))
|
56
|
+
(format t "~&Test: ~A~%" ,name)
|
57
|
+
(loop
|
58
|
+
(when (and ,show-progress-p (zerop (mod testcount 10)))
|
59
|
+
(format t ".")
|
60
|
+
(when (zerop (mod testcount 100))
|
61
|
+
(terpri))
|
62
|
+
(force-output))
|
63
|
+
(let ((errors
|
64
|
+
(handler-case
|
65
|
+
(progn ,@body)
|
66
|
+
(error (msg)
|
67
|
+
(list (format nil "~&got an unexpected error: ~A" msg))))))
|
68
|
+
(setq successp (and successp (null errors)))
|
69
|
+
(when errors
|
70
|
+
(format t "~&~4@A:~{~& ~A~}~%" testcount errors))
|
71
|
+
(incf testcount)))))
|
72
|
+
successp))
|
73
|
+
|
74
|
+
(defun simple-tests (&key (file-name
|
75
|
+
(make-pathname :name "simple"
|
76
|
+
:type nil :version nil
|
77
|
+
:defaults *this-file*))
|
78
|
+
(external-format '(:latin-1 :eol-style :lf))
|
79
|
+
verbose)
|
80
|
+
"Loops through all the forms in the file FILE-NAME and executes each
|
81
|
+
of them using EVAL. It is assumed that each FORM specifies a test
|
82
|
+
which returns a true value iff it succeeds. Prints each test form to
|
83
|
+
*STANDARD-OUTPUT* if VERBOSE is true and shows a simple progress
|
84
|
+
indicator otherwise. EXTERNAL-FORMAT is the FLEXI-STREAMS external
|
85
|
+
format which is used to read the file. Returns a true value iff all
|
86
|
+
tests succeeded."
|
87
|
+
(with-open-file (binary-stream file-name :element-type 'flex:octet)
|
88
|
+
(let ((stream (flex:make-flexi-stream binary-stream :external-format external-format))
|
89
|
+
(*package* (find-package :cl-ppcre-test)))
|
90
|
+
(do-tests ((format nil "Simple tests from file ~S" (file-namestring file-name))
|
91
|
+
(not verbose))
|
92
|
+
(let ((form (or (read stream nil) (done))))
|
93
|
+
(when verbose
|
94
|
+
(format t "~&~S" form))
|
95
|
+
(cond ((eval form) nil)
|
96
|
+
(t (list (format nil "~S returned NIL" form)))))))))
|
97
|
+
|
98
|
+
(defun random-test-function (probability)
|
99
|
+
"Returns a random character test function which contains each
|
100
|
+
character with probability PROBABILITY."
|
101
|
+
(let ((hash-table (make-hash-table)))
|
102
|
+
(dotimes (code char-code-limit)
|
103
|
+
(let ((char (code-char code)))
|
104
|
+
(when (and char (< (random 1.0d0) probability))
|
105
|
+
(setf (gethash (code-char code) hash-table) t))))
|
106
|
+
(lambda (char)
|
107
|
+
(gethash char hash-table))))
|
108
|
+
|
109
|
+
(defun test-optimized-test-functions% (probability)
|
110
|
+
"Creates a random test function with probability PROBABILITY and six
|
111
|
+
\(one for each possible \"kind\") corresponding optimized test
|
112
|
+
functions, then checks for each character in turn that all functions
|
113
|
+
agree on it."
|
114
|
+
(let* ((test-function (random-test-function probability))
|
115
|
+
(optimized-functions (loop for kind in '(nil
|
116
|
+
:hash-table
|
117
|
+
:hash-table*
|
118
|
+
:charset
|
119
|
+
:charset*
|
120
|
+
:charmap)
|
121
|
+
collect (create-optimized-test-function test-function :kind kind))))
|
122
|
+
(loop for code below char-code-limit
|
123
|
+
for char = (code-char code)
|
124
|
+
for expected-result = (and char (funcall test-function char))
|
125
|
+
always (or (null char)
|
126
|
+
(loop for optimized-function in optimized-functions
|
127
|
+
always (eq (not (funcall optimized-function char))
|
128
|
+
(not expected-result)))))))
|
129
|
+
|
130
|
+
(defun test-optimized-test-functions (&key verbose)
|
131
|
+
"Runs TEST-OPTIMIZED-TEST-FUNCTIONS% with different probabilities."
|
132
|
+
(let ((probabilities '(0 .001 .01 .1 1)))
|
133
|
+
(do-tests ("Optimized test functions - this might take some time..." (not verbose))
|
134
|
+
(let ((probability (or (pop probabilities) (done))))
|
135
|
+
(when verbose
|
136
|
+
(format t "~&Probability is ~A" probability))
|
137
|
+
(not (test-optimized-test-functions% probability))))))
|
138
|
+
|
139
|
+
(defun run-all-tests (&key more-tests verbose)
|
140
|
+
"Runs all tests for CL-PPCRE and returns a true value iff all tests
|
141
|
+
succeeded. VERBOSE is interpreted by the individual test suites.
|
142
|
+
MORE-TESTS can be a list of function designators designating
|
143
|
+
additional tests to run. This facility is used by the tests for
|
144
|
+
CL-PPCRE-UNICODE."
|
145
|
+
(let ((successp t))
|
146
|
+
(macrolet ((run-test-suite (&body body)
|
147
|
+
`(unless (progn ,@body)
|
148
|
+
(setq successp nil))))
|
149
|
+
;; run the automatically generated Perl tests
|
150
|
+
(run-test-suite (perl-test :verbose verbose))
|
151
|
+
(run-test-suite (test-optimized-test-functions :verbose verbose))
|
152
|
+
(run-test-suite (simple-tests :verbose verbose))
|
153
|
+
(when more-tests
|
154
|
+
(unless (listp more-tests)
|
155
|
+
(setq more-tests (list more-tests))
|
156
|
+
(dolist (test more-tests)
|
157
|
+
(run-test-suite (funcall test :verbose verbose))))))
|
158
|
+
(format t "~2&~:[Some tests failed~;All tests passed~]." successp)
|
159
|
+
successp))
|
@@ -0,0 +1,80 @@
|
|
1
|
+
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE-TEST; Base: 10 -*-
|
2
|
+
;;; $Header: /usr/local/cvsrep/cl-ppcre/test/unicode-tests.lisp,v 1.8 2008/07/23 00:17:53 edi Exp $
|
3
|
+
|
4
|
+
;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved.
|
5
|
+
|
6
|
+
;;; Redistribution and use in source and binary forms, with or without
|
7
|
+
;;; modification, are permitted provided that the following conditions
|
8
|
+
;;; are met:
|
9
|
+
|
10
|
+
;;; * Redistributions of source code must retain the above copyright
|
11
|
+
;;; notice, this list of conditions and the following disclaimer.
|
12
|
+
|
13
|
+
;;; * Redistributions in binary form must reproduce the above
|
14
|
+
;;; copyright notice, this list of conditions and the following
|
15
|
+
;;; disclaimer in the documentation and/or other materials
|
16
|
+
;;; provided with the distribution.
|
17
|
+
|
18
|
+
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
19
|
+
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
20
|
+
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
21
|
+
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
22
|
+
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
23
|
+
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
24
|
+
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
25
|
+
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
26
|
+
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
27
|
+
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
28
|
+
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
29
|
+
|
30
|
+
(in-package :cl-ppcre-test)
|
31
|
+
|
32
|
+
(defun unicode-test (&key (file-name
|
33
|
+
(make-pathname :name "unicodetestdata"
|
34
|
+
:type nil :version nil
|
35
|
+
:defaults *this-file*)
|
36
|
+
file-name-provided-p)
|
37
|
+
verbose)
|
38
|
+
"Loops through all test cases in FILE-NAME and prints a report if
|
39
|
+
VERBOSE is true. Returns a true value if all tests succeeded.
|
40
|
+
|
41
|
+
For the syntax of the tests in FILE-NAME refer to CL-UNICODE."
|
42
|
+
(with-open-file (stream file-name)
|
43
|
+
(let ((*regex-char-code-limit* (if file-name-provided-p *regex-char-code-limit* char-code-limit))
|
44
|
+
(*optimize-char-classes* (if file-name-provided-p *optimize-char-classes* nil))
|
45
|
+
;; we only check for correctness and don't care about speed
|
46
|
+
;; that match (but rather about space constraints of the
|
47
|
+
;; trial versions)
|
48
|
+
(*use-bmh-matchers* (if file-name-provided-p *use-bmh-matchers* nil)))
|
49
|
+
(do-tests ((format nil "Running Unicode tests in file ~S" (file-namestring file-name))
|
50
|
+
(not verbose))
|
51
|
+
(let ((input-line (or (read stream nil) (done)))
|
52
|
+
errors)
|
53
|
+
(destructuring-bind (char-code property-name expected-result)
|
54
|
+
input-line
|
55
|
+
(let ((char (and (< char-code char-code-limit) (code-char char-code))))
|
56
|
+
(when char
|
57
|
+
(when verbose
|
58
|
+
(format t "~&~A: #x~X" property-name char-code))
|
59
|
+
(let* ((string (string char))
|
60
|
+
(result-1 (scan (format nil "\\p{~A}" property-name) string))
|
61
|
+
(result-2 (scan (format nil "[\\p{~A}]" property-name) string))
|
62
|
+
(inverted-result-1 (scan (format nil "\\P{~A}" property-name) string))
|
63
|
+
(inverted-result-2 (scan (format nil "[\\P{~A}]" property-name) string)))
|
64
|
+
(unless (eq expected-result (not (not result-1)))
|
65
|
+
(push (format nil "\(code-char #x~X) should ~:[not ~;~]have matched \"\\p{~A}\""
|
66
|
+
char-code expected-result property-name)
|
67
|
+
errors))
|
68
|
+
(unless (eq expected-result (not (not result-2)))
|
69
|
+
(push (format nil "\(code-char #x~X) should ~:[not ~;~]have matched \"[\\p{~A}]\""
|
70
|
+
char-code expected-result property-name)
|
71
|
+
errors))
|
72
|
+
(unless (eq expected-result (not inverted-result-1))
|
73
|
+
(push (format nil "\(code-char #x~X) should ~:[~;not ~]have matched \"\\P{~A}\""
|
74
|
+
char-code expected-result property-name)
|
75
|
+
errors))
|
76
|
+
(unless (eq expected-result (not inverted-result-2))
|
77
|
+
(push (format nil "\(code-char #x~X) should ~:[~;not ~]have matched \"[\\P{~A}]\""
|
78
|
+
char-code expected-result property-name)
|
79
|
+
errors)))
|
80
|
+
errors))))))))
|
@@ -0,0 +1,201 @@
|
|
1
|
+
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
2
|
+
;;; $Header: /usr/local/cvsrep/cl-ppcre/util.lisp,v 1.48 2009/10/28 07:36:15 edi Exp $
|
3
|
+
|
4
|
+
;;; Utility functions and constants dealing with the character sets we
|
5
|
+
;;; use to encode character classes
|
6
|
+
|
7
|
+
;;; Copyright (c) 2002-2009, Dr. Edmund Weitz. All rights reserved.
|
8
|
+
|
9
|
+
;;; Redistribution and use in source and binary forms, with or without
|
10
|
+
;;; modification, are permitted provided that the following conditions
|
11
|
+
;;; are met:
|
12
|
+
|
13
|
+
;;; * Redistributions of source code must retain the above copyright
|
14
|
+
;;; notice, this list of conditions and the following disclaimer.
|
15
|
+
|
16
|
+
;;; * Redistributions in binary form must reproduce the above
|
17
|
+
;;; copyright notice, this list of conditions and the following
|
18
|
+
;;; disclaimer in the documentation and/or other materials
|
19
|
+
;;; provided with the distribution.
|
20
|
+
|
21
|
+
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
22
|
+
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
23
|
+
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
24
|
+
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
25
|
+
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
26
|
+
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
27
|
+
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
28
|
+
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
29
|
+
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
30
|
+
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
31
|
+
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
32
|
+
|
33
|
+
(in-package :cl-ppcre)
|
34
|
+
|
35
|
+
(defmacro defconstant (name value &optional doc)
|
36
|
+
"Make sure VALUE is evaluated only once \(to appease SBCL)."
|
37
|
+
`(cl:defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
|
38
|
+
,@(when doc (list doc))))
|
39
|
+
|
40
|
+
#+:lispworks
|
41
|
+
(eval-when (:compile-toplevel :load-toplevel :execute)
|
42
|
+
(import 'lw:with-unique-names))
|
43
|
+
|
44
|
+
#-:lispworks
|
45
|
+
(defmacro with-unique-names ((&rest bindings) &body body)
|
46
|
+
"Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*
|
47
|
+
|
48
|
+
Executes a series of forms with each VAR bound to a fresh,
|
49
|
+
uninterned symbol. The uninterned symbol is as if returned by a call
|
50
|
+
to GENSYM with the string denoted by X - or, if X is not supplied, the
|
51
|
+
string denoted by VAR - as argument.
|
52
|
+
|
53
|
+
The variable bindings created are lexical unless special declarations
|
54
|
+
are specified. The scopes of the name bindings and declarations do not
|
55
|
+
include the Xs.
|
56
|
+
|
57
|
+
The forms are evaluated in order, and the values of all but the last
|
58
|
+
are discarded \(that is, the body is an implicit PROGN)."
|
59
|
+
;; reference implementation posted to comp.lang.lisp as
|
60
|
+
;; <cy3bshuf30f.fsf@ljosa.com> by Vebjorn Ljosa - see also
|
61
|
+
;; <http://www.cliki.net/Common%20Lisp%20Utilities>
|
62
|
+
`(let ,(mapcar #'(lambda (binding)
|
63
|
+
(check-type binding (or cons symbol))
|
64
|
+
(if (consp binding)
|
65
|
+
(destructuring-bind (var x) binding
|
66
|
+
(check-type var symbol)
|
67
|
+
`(,var (gensym ,(etypecase x
|
68
|
+
(symbol (symbol-name x))
|
69
|
+
(character (string x))
|
70
|
+
(string x)))))
|
71
|
+
`(,binding (gensym ,(symbol-name binding)))))
|
72
|
+
bindings)
|
73
|
+
,@body))
|
74
|
+
|
75
|
+
#+:lispworks
|
76
|
+
(eval-when (:compile-toplevel :load-toplevel :execute)
|
77
|
+
(setf (macro-function 'with-rebinding)
|
78
|
+
(macro-function 'lw:rebinding)))
|
79
|
+
|
80
|
+
#-:lispworks
|
81
|
+
(defmacro with-rebinding (bindings &body body)
|
82
|
+
"WITH-REBINDING ( { var | (var prefix) }* ) form*
|
83
|
+
|
84
|
+
Evaluates a series of forms in the lexical environment that is
|
85
|
+
formed by adding the binding of each VAR to a fresh, uninterned
|
86
|
+
symbol, and the binding of that fresh, uninterned symbol to VAR's
|
87
|
+
original value, i.e., its value in the current lexical environment.
|
88
|
+
|
89
|
+
The uninterned symbol is created as if by a call to GENSYM with the
|
90
|
+
string denoted by PREFIX - or, if PREFIX is not supplied, the string
|
91
|
+
denoted by VAR - as argument.
|
92
|
+
|
93
|
+
The forms are evaluated in order, and the values of all but the last
|
94
|
+
are discarded \(that is, the body is an implicit PROGN)."
|
95
|
+
;; reference implementation posted to comp.lang.lisp as
|
96
|
+
;; <cy3wv0fya0p.fsf@ljosa.com> by Vebjorn Ljosa - see also
|
97
|
+
;; <http://www.cliki.net/Common%20Lisp%20Utilities>
|
98
|
+
(loop for binding in bindings
|
99
|
+
for var = (if (consp binding) (car binding) binding)
|
100
|
+
for name = (gensym)
|
101
|
+
collect `(,name ,var) into renames
|
102
|
+
collect ``(,,var ,,name) into temps
|
103
|
+
finally (return `(let ,renames
|
104
|
+
(with-unique-names ,bindings
|
105
|
+
`(let (,,@temps)
|
106
|
+
,,@body))))))
|
107
|
+
|
108
|
+
(declaim (inline digit-char-p))
|
109
|
+
(defun digit-char-p (chr)
|
110
|
+
(declare #.*standard-optimize-settings*)
|
111
|
+
"Tests whether a character is a decimal digit, i.e. the same as
|
112
|
+
Perl's [\\d]. Note that this function shadows the standard Common
|
113
|
+
Lisp function CL:DIGIT-CHAR-P."
|
114
|
+
(char<= #\0 chr #\9))
|
115
|
+
|
116
|
+
(declaim (inline word-char-p))
|
117
|
+
(defun word-char-p (chr)
|
118
|
+
(declare #.*standard-optimize-settings*)
|
119
|
+
"Tests whether a character is a \"word\" character. In the ASCII
|
120
|
+
charset this is equivalent to a-z, A-Z, 0-9, or _, i.e. the same as
|
121
|
+
Perl's [\\w]."
|
122
|
+
(or (alphanumericp chr)
|
123
|
+
(char= chr #\_)))
|
124
|
+
|
125
|
+
(defconstant +whitespace-char-string+
|
126
|
+
(coerce '(#\Space #\Tab #\Linefeed #\Return #\Page) 'string)
|
127
|
+
"A string of all characters which are considered to be whitespace.
|
128
|
+
Same as Perl's [\\s].")
|
129
|
+
|
130
|
+
(defun whitespacep (chr)
|
131
|
+
(declare #.*special-optimize-settings*)
|
132
|
+
"Tests whether a character is whitespace, i.e. whether it would
|
133
|
+
match [\\s] in Perl."
|
134
|
+
(find chr +whitespace-char-string+ :test #'char=))
|
135
|
+
|
136
|
+
(defmacro maybe-coerce-to-simple-string (string)
|
137
|
+
"Coerces STRING to a simple STRING unless it already is one."
|
138
|
+
(with-unique-names (=string=)
|
139
|
+
`(let ((,=string= ,string))
|
140
|
+
(cond (#+:lispworks
|
141
|
+
(lw:simple-text-string-p ,=string=)
|
142
|
+
#-:lispworks
|
143
|
+
(simple-string-p ,=string=)
|
144
|
+
,=string=)
|
145
|
+
(t
|
146
|
+
(coerce ,=string=
|
147
|
+
#+:lispworks 'lw:simple-text-string
|
148
|
+
#-:lispworks 'simple-string))))))
|
149
|
+
|
150
|
+
(declaim (inline nsubseq))
|
151
|
+
(defun nsubseq (sequence start &optional (end (length sequence)))
|
152
|
+
"Returns a subsequence by pointing to location in original sequence."
|
153
|
+
(make-array (- end start)
|
154
|
+
:element-type (array-element-type sequence)
|
155
|
+
:displaced-to sequence
|
156
|
+
:displaced-index-offset start))
|
157
|
+
|
158
|
+
(defun normalize-var-list (var-list)
|
159
|
+
"Utility function for REGISTER-GROUPS-BIND and DO-REGISTER-GROUPS.
|
160
|
+
Creates the long form \(a list of \(FUNCTION VAR) entries) out of the
|
161
|
+
short form of VAR-LIST."
|
162
|
+
(loop for element in var-list
|
163
|
+
if (consp element)
|
164
|
+
nconc (loop for var in (rest element)
|
165
|
+
collect (list (first element) var))
|
166
|
+
else
|
167
|
+
collect (list '(function identity) element)))
|
168
|
+
|
169
|
+
(defun string-list-to-simple-string (string-list)
|
170
|
+
"Concatenates a list of strings to one simple-string."
|
171
|
+
(declare #.*standard-optimize-settings*)
|
172
|
+
;; this function provided by JP Massar; note that we can't use APPLY
|
173
|
+
;; with CONCATENATE here because of CALL-ARGUMENTS-LIMIT
|
174
|
+
(let ((total-size 0))
|
175
|
+
(declare (fixnum total-size))
|
176
|
+
(dolist (string string-list)
|
177
|
+
#-:genera (declare (string string))
|
178
|
+
(incf total-size (length string)))
|
179
|
+
(let ((result-string (make-sequence #-:lispworks 'simple-string
|
180
|
+
#+:lispworks 'lw:simple-text-string
|
181
|
+
total-size))
|
182
|
+
(curr-pos 0))
|
183
|
+
(declare (fixnum curr-pos))
|
184
|
+
(dolist (string string-list)
|
185
|
+
#-:genera (declare (string string))
|
186
|
+
(replace result-string string :start1 curr-pos)
|
187
|
+
(incf curr-pos (length string)))
|
188
|
+
result-string)))
|
189
|
+
|
190
|
+
(defun complement* (test-function)
|
191
|
+
"Like COMPLEMENT but optimized for unary functions."
|
192
|
+
(declare #.*standard-optimize-settings*)
|
193
|
+
(typecase test-function
|
194
|
+
(function
|
195
|
+
(lambda (char)
|
196
|
+
(declare (character char))
|
197
|
+
(not (funcall (the function test-function) char))))
|
198
|
+
(otherwise
|
199
|
+
(lambda (char)
|
200
|
+
(declare (character char))
|
201
|
+
(not (funcall test-function char))))))
|