clucumber 0.1.1 → 0.2.0

data/lib/clucumber/vendor/cl-unicode/build/util.lisp

@@ -0,0 +1,182 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-UNICODE; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-unicode/build/util.lisp,v 1.12 2008/07/21 14:23:09 edi Exp $
+
+;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-unicode)
+
+(defvar *this-file* (load-time-value
+                     (or #.*compile-file-pathname* *load-pathname*))
+  "The location of this source file.  Needed to find the data files.")
+
+(defvar *char-database* nil
+  "This will be a vector of CHAR-INFO objects which keeps track of the
+information parsed from the Unicode files while the build process
+runs.  This \"database\" is not used by CL-UNICODE itself.  It only
+serves as a temporary storage during the build process.")
+
+(defun make-empty-char-database ()
+  "Creates and returns an array of length +CODE-POINT-LIMIT+
+initialized with NILs."
+  (make-array +code-point-limit+ :initial-element nil))
+
+(defun initialize-property-symbols ()
+  "Clears the hash table *CANONICAL-NAMES* and initializes it with
+certain values which might otherwise not be seen when the Unicode
+files are parsed."
+  (clrhash *canonical-names*)
+  (dolist (name '("Cn" "AL" "R" "L" "Decimal" "Digit" "Numeric" "BidiMirrored" "NoncharacterCodePoint"))
+    (register-property-symbol name)))
+
+(defun extract-variables (bindings)
+  "Helper function for the WITH-UNICODE-FILE macro.  Collects the
+variables from the list BINDINGS where atoms as well as the first
+element of BINDINGS are left as is and lists are replaced with their
+first elements.  The symbol _ \(underline) is skipped, i.e. not
+returned."
+  (cons (first bindings)
+        (loop for binding in (rest bindings)
+              unless (eq binding '_)
+              when (listp binding)
+              collect (first binding)
+              else collect binding)))
+
+(defun extract-types (bindings)
+  "Helper function for the WITH-UNICODE-FILE macro.  Collects the type
+spec from the list BINDINGS where it is assumed the for lists the type
+spec is the second element and for atoms the type spec is defaulted to
+STRING.  The first argument of BINDINGS is skipped, and the type spec
+NIL is included whenever the symbol _ \(underline) is seen."
+  (loop for binding in (rest bindings)
+        when (eq binding '_)
+        collect nil
+        else when (listp binding)
+        collect (second binding)
+        else collect 'string))
+
+(defun extract-defaults (bindings)
+  "Helper function for the WITH-UNICODE-FILE macro.  Collects the
+default values from the list BINDINGS where it is assumed the for
+lists the default value is the third element and for atoms the default
+value is :ERROR \(meaning to signal an error).  The first argument of
+BINDINGS is skipped, and the default value NIL is included whenever
+the symbol _ \(underline) is seen."
+  (loop for binding in (rest bindings)
+        when (eq binding '_)
+        collect nil
+        else when (and (listp binding) (cddr binding))
+        collect (third binding)
+        else collect :error))
+
+(defun code-point-range-start (range)
+  "Returns the first code point of the code point \"range\" RANGE
+where RANGE is either an integer denoting one code point or a cons of
+the form (A . B) denoting the code points from A to B \(inclusive)."
+  (cond ((atom range) range)
+        (t (car range))))
+
+(defun parse-code-point (string)
+  "Parses a string which is supposed to be the hexadecimal
+representation of one code point or a range of code points \(written
+with two dots between them like \"0AE0..0AF3\").  Returns a single
+integer \(for one code point) or a cons of two integers \(for a
+range)."
+  (destructuring-bind (first &optional second)
+      (mapcar 'parse-hex (ppcre:split "\\.\\." string))
+    (if second (cons first second) first)))
+
+(defgeneric parse-value (value type default)
+  (:documentation "Parses the string VALUE coming from a Unicode data
+file and converts it according to the type spec TYPE \(a symbol
+denoting a type which is not necessarily a Lisp type).  If VALUE is
+the empty string, DEFAULT is returned instead unless DEFAULT is :ERROR
+in which case an error is signalled.")
+  (:method (value type default)
+   "The default method for unrecognized type specs."
+   (error "Don't know how to parse type ~S." type))
+  (:method :around (value type default)
+   "The method to take care of default values."
+   (cond ((and (string= value "") (eq default :error))
+          (error "No value and no default provided"))
+         ((string= value "") default)
+         (t (call-next-method)))))
+
+(defmethod parse-value (value (type (eql 'string)) default)
+  "The method for strings simply returns VALUE."
+  value)
+
+(defmethod parse-value (value (type (eql 'boolean)) default)
+  "The method for BOOLEAN only accepts the strings \"Y\" and \"N\"."
+  (cond ((string= value "Y") t)
+        ((string= value "N") nil)
+        (t (error "Expected boolean, but got ~S." value))))
+
+(defmethod parse-value (value (type (eql 'symbol)) default)
+  "The method for symbol which converts the string to a \"property
+symbol\" \(see PROPERTY-SYMBOL) and registers it \(see
+REGISTER-PROPERTY-SYMBOL)."
+  (register-property-symbol value))
+
+(defmethod parse-value (value (type (eql 'integer)) default)
+  "The method for \(decimal) integers."
+  (parse-integer value))
+
+(defmethod parse-value (value (type (eql 'hex)) default)
+  "The method for hexadecimal integers."
+  (parse-hex value))
+
+(defmethod parse-value (value (type (eql 'rational)) default)
+  "The method for rationals which are written like Lisp rationals."
+  (destructuring-bind (numerator &optional (denominator 1))
+      (mapcar 'parse-integer (ppcre:split "/" value))
+    (/ numerator denominator)))
+
+(defmethod parse-value (value (type (eql 'age)) default)
+  "The method for Unicode \"age\" values which are converted to a
+list of two integers, the major and minor version."
+  (destructuring-bind (major minor)
+      (mapcar 'parse-integer (ppcre:split "\\." value))
+    (list major minor)))
+
+(defun parse-one-line (parts &optional types defaults)
+  "Parses one line of a Unicode data file and returns a list of Lisp
+objects as determined by TYPES and DEFAULTS.  It is assumed that the
+line was already split into a list PARTS of individual strings, one
+for each value/object.  The elements of TYPES and DEFAULTS are
+interpreted as by PARSE-VALUE except that we skip one element of PARTS
+for each NIL in TYPES.  The first element of PARTS is always
+interpreted as a code point \(range), i.e. TYPES and DEFAULTS only
+apply to the rest of PARTS.
+
+Note that a call like \(PARSE-ONE-LINE PARTS) means that just the code
+point part is parsed and returned."
+  (cons (parse-code-point (first parts))
+        (loop for part in (rest parts)
+              for type in types
+              for default in defaults
+              when type 
+              collect (parse-value part type default))))

data/lib/clucumber/vendor/cl-unicode/cl-unicode.asd

@@ -0,0 +1,90 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-unicode/cl-unicode.asd,v 1.22 2008/07/24 14:56:31 edi Exp $
+
+;;; Copyright (c) 2008, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-user)
+
+(defpackage :cl-unicode-asd
+  (:use :cl :asdf))
+
+(in-package :cl-unicode-asd)
+
+(defsystem :build-cl-unicode
+  :serial t
+  ;; FLEXI-STREAMS is only needed to /build/ CL-UNICODE
+  :depends-on (:flexi-streams)
+  :components  ((:file "packages")
+                (:file "specials")
+                (:file "util")
+                (:module "build"
+                 :serial t
+                 :components ((:file "util")
+                              (:file "char-info")
+                              (:file "read")
+                              (:file "dump")))))
+
+(defclass generated-cl-source-file (cl-source-file)
+  ()
+  (:documentation "A subclass of CL-SOURCE-FILE for source files which
+might have to be generated by loading the BUILD-CL-UNICODE system
+first."))
+
+(defmethod perform ((operation compile-op) (component generated-cl-source-file))
+  "A method which makes sure that the files of type
+GENERATED-CL-SOURCE-FILE actually exist before we try to compile
+them."
+  (unless (every 'probe-file (input-files operation component))
+    (operate 'load-op :build-cl-unicode))
+  (call-next-method))
+
+(defsystem :cl-unicode
+  :version "0.1.1"
+  :serial t
+  :depends-on (:cl-ppcre)
+  :components ((:file "packages")
+               (:file "specials")
+               (:file "util")
+               (:file "conditions")
+               (:generated-cl-source-file "lists")
+               (:generated-cl-source-file "hash-tables")
+               (:file "api")
+               (:generated-cl-source-file "methods")
+               (:file "test-functions")
+               (:file "derived")
+               (:file "alias")))
+               
+(defsystem :cl-unicode-test
+  :depends-on (:cl-unicode)
+  :components ((:module "test"
+                        :serial t
+                        :components ((:file "packages")
+                                     (:file "tests")))))
+
+(defmethod perform ((o test-op) (c (eql (find-system :cl-unicode))))
+  (operate 'load-op :cl-unicode-test)
+  (funcall (intern (symbol-name :run-all-tests) (find-package :cl-unicode-test))))

data/lib/clucumber/vendor/cl-unicode/conditions.lisp

@@ -0,0 +1,54 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-UNICODE; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-unicode/conditions.lisp,v 1.3 2008/07/22 02:42:13 edi Exp $
+
+;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-unicode)
+
+(define-condition unicode-error (error)
+  ()
+  (:documentation "All errors signalled by CL-UNICODE are of this type."))
+
+(define-condition simple-unicode-error (unicode-error simple-condition)
+  ()
+  (:documentation "A subclass of UNICODE-ERROR where the caller can
+supply a format control and format arguments."))
+
+(defun signal-unicode-error (format-control &rest format-arguments)
+  "Utility function to signal conditions of type SIMPLE-UNICODE-ERROR."
+  (error 'simple-unicode-error
+          :format-control format-control
+          :format-arguments format-arguments))
+
+(define-condition character-not-found (unicode-error reader-error)
+  ((name :initarg :name))
+  (:report (lambda (condition stream)
+             (with-slots (name)
+                 condition
+               (format stream "There is no character named ~S." name))))
+  (:documentation "Error signalled by UNICODE-NAME-READER if a
+character wasn't found."))

data/lib/clucumber/vendor/cl-unicode/derived.lisp

@@ -0,0 +1,120 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-UNICODE; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-unicode/derived.lisp,v 1.14 2008/07/20 21:01:08 edi Exp $
+
+;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-unicode)
+
+(defconstant +xid-difference+
+  ;; the usual mumbo jumbo for SBCL...
+  (if (boundp '+xid-difference+)
+    (symbol-value '+xid-difference+)
+    '(#x37a
+      (#x309b . #x309c)
+      (#xfc5e . #xfc63)
+      (#xfdfa . #xfdfb)
+      #xfe70
+      #xfe72
+      #xfe74
+      #xfe76
+      #xfe78
+      #xfe7a
+      #xfe7c
+      #xfe7e)))
+
+(defvar *derived-map*
+  `(("Any")
+    ("LC" "Lu" "Ll" "Lt")
+    ("L" "LC" "Lm" "Lo")
+    ("M" "Mn" "Mc" "Me")
+    ("N" "Nd" "Nl" "No")
+    ("P" "Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po")
+    ("S" "Sm" "Sc" "Sk" "So")
+    ("Z" "Zs" "Zl" "Zp")
+    ("C" "Cc" "Cf" "Cs" "Co" "Cn")
+    ("Math" "Sm" "OtherMath")
+    ("Alphabetic" "L" "Nl" "OtherAlphabetic")
+    ("Lowercase" "Ll" "OtherLowercase")
+    ("Uppercase" "Lu" "OtherUppercase")
+    ("GraphemeExtend" "Me" "Mn" "OtherGraphemeExtend")
+    ("GraphemeBase" ("C" "Zl" "Zp" "GraphemeExtend"))
+    ("IDStart" "L" "Nl" "OtherIDStart" ("PatternSyntax" "PatternWhiteSpace"))
+    ("IDContinue" "IDStart" "Mn" "Mc" "Nd" "Pc" "OtherIDContinue" ("PatternSyntax" "PatternWhiteSpace"))
+    ("XIDStart" "IDStart" (,@+xid-difference+ #xe33 #xeb3 (#xff9e . #xff9f)))
+    ("XIDContinue" "IDContinue" ,+xid-difference+)
+    ("DefaultIgnorableCodePoint" "OtherDefaultIgnorableCodePoint" "Cf" "VariationSelector"
+                                 ("WhiteSpace" (#xfff9 . #xfffb) (#x600 . #x603) #x6dd #x70f))))
+
+;; todo: xid_start, xid_continue,
+
+(defun build-derived-test-function (property-designators)
+  (labels ((build-test-function (designator)
+             (etypecase designator
+               (string
+                (let ((test-function (gethash (gethash designator *property-map*) *property-tests*)))
+                  (assert test-function (designator)
+                    "Unknown property name ~S." designator)
+                  test-function))
+               (integer
+                (lambda (c)
+                  (= (ensure-code-point c) designator)))
+               (cons
+                (let ((from (car designator))
+                      (to (car designator)))
+                (assert (and (typep from 'integer) (typep to 'integer)) (designator)
+                  "Car and cdr of ~S must both be integers." designator)
+                (lambda (c)
+                  (<= from (ensure-code-point c) to))))))
+           (collect-test-functions (designators)
+             (loop for designator in designators
+                   collect (build-test-function designator))))
+    (let ((positive-test-functions
+           (collect-test-functions (remove-if-not 'atom property-designators)))
+          (negative-test-functions
+           (collect-test-functions (find-if-not 'atom property-designators))))
+      (cond (negative-test-functions
+             (lambda (c)
+               (and (or (null positive-test-functions)
+                        (loop for test-function in positive-test-functions
+                              thereis (funcall (the function test-function) c)))
+                    (not (loop for test-function in negative-test-functions
+                               thereis (funcall (the function test-function) c))))))                  
+            (t
+             (lambda (c)
+               (or (null positive-test-functions)
+                   (loop for test-function in positive-test-functions
+                         thereis (funcall (the function test-function) c)))))))))
+               
+(defun build-derived-test-functions ()
+  (loop for (name . property-names) in *derived-map*
+        for symbol = (register-property-symbol name) do
+        (assert (null (gethash symbol *property-tests*)) (name)
+          "There is already a property named ~S." name)
+        (setf (gethash symbol *property-tests*)
+              (build-derived-test-function property-names)
+              (gethash name *property-map*)
+              symbol)))