[bknr-cvs] r2205 - in branches/trunk-reorg/thirdparty: . puri-1.5.1 trivial-gray-streams-2006-09-16 trivial-gray-streams-2006-09-16/CVS - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

4 Oct 2007

Author: hhubner
Date: 2007-10-04 15:13:23 -0400 (Thu, 04 Oct 2007)
New Revision: 2205

Added:
   branches/trunk-reorg/thirdparty/puri-1.5.1/
   branches/trunk-reorg/thirdparty/puri-1.5.1/LICENSE
   branches/trunk-reorg/thirdparty/puri-1.5.1/README
   branches/trunk-reorg/thirdparty/puri-1.5.1/puri.asd
   branches/trunk-reorg/thirdparty/puri-1.5.1/src.lisp
   branches/trunk-reorg/thirdparty/puri-1.5.1/tests.lisp
   branches/trunk-reorg/thirdparty/puri-1.5.1/uri.html
   branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/
   branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/COPYING
   branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/
   branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Entries
   branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Repository
   branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Root
   branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/Makefile
   branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/README
   branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/mixin.lisp
   branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/package.lisp
   branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/trivial-gray-streams.asd
Log:
updating

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/LICENSE
===================================================================

--- branches/trunk-reorg/thirdparty/puri-1.5.1/LICENSE	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/puri-1.5.1/LICENSE	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,574 @@
+Copyright (c) 1999-2001 Franz, Inc. 
+Copyright (c) 2003 Kevin Rosenberg
+All rights reserved.
+
+PURI is licensed under the terms of the Lisp Lesser GNU Public
+License, known as the LLGPL.  The LLGPL consists of a preamble (see
+below) and the Lessor GNU Public License 2.1 (LGPL-2.1).  Where these
+conflict, the preamble takes precedence.  PURI is referenced in the
+preamble as the "LIBRARY."  
+
+PURI is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.
+
+
+
+Preamble to the Gnu Lesser General Public License
+-------------------------------------------------
+Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704
+
+The concept of the GNU Lesser General Public License version 2.1
+("LGPL") has been adopted to govern the use and distribution of
+above-mentioned application. However, the LGPL uses terminology that
+is more appropriate for a program written in C than one written in
+Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if
+certain clarifications are made. This document details those
+clarifications. Accordingly, the license for the open-source Lisp
+applications consists of this document plus the LGPL. Wherever there
+is a conflict between this document and the LGPL, this document takes
+precedence over the LGPL.
+
+A "Library" in Lisp is a collection of Lisp functions, data and
+foreign modules. The form of the Library can be Lisp source code (for
+processing by an interpreter) or object code (usually the result of
+compilation of source code or built with some other
+mechanisms). Foreign modules are object code in a form that can be
+linked into a Lisp executable. When we speak of functions we do so in
+the most general way to include, in addition, methods and unnamed
+functions. Lisp "data" is also a general term that includes the data
+structures resulting from defining Lisp classes. A Lisp application
+may include the same set of Lisp objects as does a Library, but this
+does not mean that the application is necessarily a "work based on the
+Library" it contains.
+
+The Library consists of everything in the distribution file set before
+any modifications are made to the files. If any of the functions or
+classes in the Library are redefined in other files, then those
+redefinitions ARE considered a work based on the Library. If
+additional methods are added to generic functions in the Library,
+those additional methods are NOT considered a work based on the
+Library. If Library classes are subclassed, these subclasses are NOT
+considered a work based on the Library. If the Library is modified to
+explicitly call other functions that are neither part of Lisp itself
+nor an available add-on module to Lisp, then the functions called by
+the modified Library ARE considered a work based on the Library. The
+goal is to ensure that the Library will compile and run without
+getting undefined function errors.
+
+It is permitted to add proprietary source code to the Library, but it
+must be done in a way such that the Library will still run without
+that proprietary code present. Section 5 of the LGPL distinguishes
+between the case of a library being dynamically linked at runtime and
+one being statically linked at build time. Section 5 of the LGPL
+states that the former results in an executable that is a "work that
+uses the Library." Section 5 of the LGPL states that the latter
+results in one that is a "derivative of the Library", which is
+therefore covered by the LGPL. Since Lisp only offers one choice,
+which is to link the Library into an executable at build time, we
+declare that, for the purpose applying the LGPL to the Library, an
+executable that results from linking a "work that uses the Library"
+with the Library is considered a "work that uses the Library" and is
+therefore NOT covered by the LGPL.
+
+Because of this declaration, section 6 of LGPL is not applicable to
+the Library. However, in connection with each distribution of this
+executable, you must also deliver, in accordance with the terms and
+conditions of the LGPL, the source code of Library (or your derivative
+thereof) that is incorporated into this executable.
+
+
+
+                  GNU LESSER GENERAL PUBLIC LICENSE
+                       Version 2.1, February 1999
+
+ Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+     59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL.  It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+                            Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+Licenses are intended to guarantee your freedom to share and change
+free software--to make sure the software is free for all its users.
+
+  This license, the Lesser General Public License, applies to some
+specially designated software packages--typically libraries--of the
+Free Software Foundation and other authors who decide to use it.  You
+can use it too, but we suggest you first think carefully about whether
+this license or the ordinary General Public License is the better
+strategy to use in any particular case, based on the explanations
+below.
+
+  When we speak of free software, we are referring to freedom of use,
+not price.  Our General Public Licenses are designed to make sure that
+you have the freedom to distribute copies of free software (and charge
+for this service if you wish); that you receive source code or can get
+it if you want it; that you can change the software and use pieces of
+it in new free programs; and that you are informed that you can do
+these things.
+
+  To protect your rights, we need to make restrictions that forbid
+distributors to deny you these rights or to ask you to surrender these
+rights.  These restrictions translate to certain responsibilities for
+you if you distribute copies of the library or if you modify it.
+
+  For example, if you distribute copies of the library, whether gratis
+or for a fee, you must give the recipients all the rights that we gave
+you.  You must make sure that they, too, receive or can get the source
+code.  If you link other code with the library, you must provide
+complete object files to the recipients, so that they can relink them
+with the library after making changes to the library and recompiling
+it.  And you must show them these terms so they know their rights.
+
+  We protect your rights with a two-step method: (1) we copyright the
+library, and (2) we offer you this license, which gives you legal
+permission to copy, distribute and/or modify the library.
+
+  To protect each distributor, we want to make it very clear that
+there is no warranty for the free library.  Also, if the library is
+modified by someone else and passed on, the recipients should know
+that what they have is not the original version, so that the original
+author's reputation will not be affected by problems that might be
+introduced by others.
+^L
+  Finally, software patents pose a constant threat to the existence of
+any free program.  We wish to make sure that a company cannot
+effectively restrict the users of a free program by obtaining a
+restrictive license from a patent holder.  Therefore, we insist that
+any patent license obtained for a version of the library must be
+consistent with the full freedom of use specified in this license.
+
+  Most GNU software, including some libraries, is covered by the
+ordinary GNU General Public License.  This license, the GNU Lesser
+General Public License, applies to certain designated libraries, and
+is quite different from the ordinary General Public License.  We use
+this license for certain libraries in order to permit linking those
+libraries into non-free programs.
+
+  When a program is linked with a library, whether statically or using
+a shared library, the combination of the two is legally speaking a
+combined work, a derivative of the original library.  The ordinary
+General Public License therefore permits such linking only if the
+entire combination fits its criteria of freedom.  The Lesser General
+Public License permits more lax criteria for linking other code with
+the library.
+
+  We call this license the "Lesser" General Public License because it
+does Less to protect the user's freedom than the ordinary General
+Public License.  It also provides other free software developers Less
+of an advantage over competing non-free programs.  These disadvantages
+are the reason we use the ordinary General Public License for many
+libraries.  However, the Lesser license provides advantages in certain
+special circumstances.
+
+  For example, on rare occasions, there may be a special need to
+encourage the widest possible use of a certain library, so that it
+becomes a de-facto standard.  To achieve this, non-free programs must
+be allowed to use the library.  A more frequent case is that a free
+library does the same job as widely used non-free libraries.  In this
+case, there is little to gain by limiting the free library to free
+software only, so we use the Lesser General Public License.
+
+  In other cases, permission to use a particular library in non-free
+programs enables a greater number of people to use a large body of
+free software.  For example, permission to use the GNU C Library in
+non-free programs enables many more people to use the whole GNU
+operating system, as well as its variant, the GNU/Linux operating
+system.
+
+  Although the Lesser General Public License is Less protective of the
+users' freedom, it does ensure that the user of a program that is
+linked with the Library has the freedom and the wherewithal to run
+that program using a modified version of the Library.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.  Pay close attention to the difference between a
+"work based on the library" and a "work that uses the library".  The
+former contains code derived from the library, whereas the latter must
+be combined with the library in order to run.
+^L
+                  GNU LESSER GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License Agreement applies to any software library or other
+program which contains a notice placed by the copyright holder or
+other authorized party saying it may be distributed under the terms of
+this Lesser General Public License (also called "this License").
+Each licensee is addressed as "you".
+
+  A "library" means a collection of software functions and/or data
+prepared so as to be conveniently linked with application programs
+(which use some of those functions and data) to form executables.
+
+  The "Library", below, refers to any such software library or work
+which has been distributed under these terms.  A "work based on the
+Library" means either the Library or any derivative work under
+copyright law: that is to say, a work containing the Library or a
+portion of it, either verbatim or with modifications and/or translated
+straightforwardly into another language.  (Hereinafter, translation is
+included without limitation in the term "modification".)
+
+  "Source code" for a work means the preferred form of the work for
+making modifications to it.  For a library, complete source code means
+all the source code for all modules it contains, plus any associated
+interface definition files, plus the scripts used to control
+compilation and installation of the library.
+
+  Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running a program using the Library is not restricted, and output from
+such a program is covered only if its contents constitute a work based
+on the Library (independent of the use of the Library in a tool for
+writing it).  Whether that is true depends on what the Library does
+and what the program that uses the Library does.
+
+  1. You may copy and distribute verbatim copies of the Library's
+complete source code as you receive it, in any medium, provided that
+you conspicuously and appropriately publish on each copy an
+appropriate copyright notice and disclaimer of warranty; keep intact
+all the notices that refer to this License and to the absence of any
+warranty; and distribute a copy of this License along with the
+Library.
+
+  You may charge a fee for the physical act of transferring a copy,
+and you may at your option offer warranty protection in exchange for a
+fee.
+
+  2. You may modify your copy or copies of the Library or any portion
+of it, thus forming a work based on the Library, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) The modified work must itself be a software library.
+
+    b) You must cause the files modified to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    c) You must cause the whole of the work to be licensed at no
+    charge to all third parties under the terms of this License.
+
+    d) If a facility in the modified Library refers to a function or a
+    table of data to be supplied by an application program that uses
+    the facility, other than as an argument passed when the facility
+    is invoked, then you must make a good faith effort to ensure that,
+    in the event an application does not supply such function or
+    table, the facility still operates, and performs whatever part of
+    its purpose remains meaningful.
+
+    (For example, a function in a library to compute square roots has
+    a purpose that is entirely well-defined independent of the
+    application.  Therefore, Subsection 2d requires that any
+    application-supplied function or table used by this function must
+    be optional: if the application does not supply it, the square
+    root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Library,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Library, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote
+it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library
+with the Library (or with a work based on the Library) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may opt to apply the terms of the ordinary GNU General Public
+License instead of this License to a given copy of the Library.  To do
+this, you must alter all the notices that refer to this License, so
+that they refer to the ordinary GNU General Public License, version 2,
+instead of to this License.  (If a newer version than version 2 of the
+ordinary GNU General Public License has appeared, then you can specify
+that version instead if you wish.)  Do not make any other change in
+these notices.
+^L
+  Once this change is made in a given copy, it is irreversible for
+that copy, so the ordinary GNU General Public License applies to all
+subsequent copies and derivative works made from that copy.
+
+  This option is useful when you wish to copy part of the code of
+the Library into a program that is not a library.
+
+  4. You may copy and distribute the Library (or a portion or
+derivative of it, under Section 2) in object code or executable form
+under the terms of Sections 1 and 2 above provided that you accompany
+it with the complete corresponding machine-readable source code, which
+must be distributed under the terms of Sections 1 and 2 above on a
+medium customarily used for software interchange.
+
+  If distribution of object code is made by offering access to copy
+from a designated place, then offering equivalent access to copy the
+source code from the same place satisfies the requirement to
+distribute the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  5. A program that contains no derivative of any portion of the
+Library, but is designed to work with the Library by being compiled or
+linked with it, is called a "work that uses the Library".  Such a
+work, in isolation, is not a derivative work of the Library, and
+therefore falls outside the scope of this License.
+
+  However, linking a "work that uses the Library" with the Library
+creates an executable that is a derivative of the Library (because it
+contains portions of the Library), rather than a "work that uses the
+library".  The executable is therefore covered by this License.
+Section 6 states terms for distribution of such executables.
+
+  When a "work that uses the Library" uses material from a header file
+that is part of the Library, the object code for the work may be a
+derivative work of the Library even though the source code is not.
+Whether this is true is especially significant if the work can be
+linked without the Library, or if the work is itself a library.  The
+threshold for this to be true is not precisely defined by law.
+
+  If such an object file uses only numerical parameters, data
+structure layouts and accessors, and small macros and small inline
+functions (ten lines or less in length), then the use of the object
+file is unrestricted, regardless of whether it is legally a derivative
+work.  (Executables containing this object code plus portions of the
+Library will still fall under Section 6.)
+
+  Otherwise, if the work is a derivative of the Library, you may
+distribute the object code for the work under the terms of Section 6.
+Any executables containing that work also fall under Section 6,
+whether or not they are linked directly with the Library itself.
+^L
+  6. As an exception to the Sections above, you may also combine or
+link a "work that uses the Library" with the Library to produce a
+work containing portions of the Library, and distribute that work
+under terms of your choice, provided that the terms permit
+modification of the work for the customer's own use and reverse
+engineering for debugging such modifications.
+
+  You must give prominent notice with each copy of the work that the
+Library is used in it and that the Library and its use are covered by
+this License.  You must supply a copy of this License.  If the work
+during execution displays copyright notices, you must include the
+copyright notice for the Library among them, as well as a reference
+directing the user to the copy of this License.  Also, you must do one
+of these things:
+
+    a) Accompany the work with the complete corresponding
+    machine-readable source code for the Library including whatever
+    changes were used in the work (which must be distributed under
+    Sections 1 and 2 above); and, if the work is an executable linked
+    with the Library, with the complete machine-readable "work that
+    uses the Library", as object code and/or source code, so that the
+    user can modify the Library and then relink to produce a modified
+    executable containing the modified Library.  (It is understood
+    that the user who changes the contents of definitions files in the
+    Library will not necessarily be able to recompile the application
+    to use the modified definitions.)
+
+    b) Use a suitable shared library mechanism for linking with the
+    Library.  A suitable mechanism is one that (1) uses at run time a
+    copy of the library already present on the user's computer system,
+    rather than copying library functions into the executable, and (2)
+    will operate properly with a modified version of the library, if
+    the user installs one, as long as the modified version is
+    interface-compatible with the version that the work was made with.
+
+    c) Accompany the work with a written offer, valid for at least
+    three years, to give the same user the materials specified in
+    Subsection 6a, above, for a charge no more than the cost of
+    performing this distribution.
+
+    d) If distribution of the work is made by offering access to copy
+    from a designated place, offer equivalent access to copy the above
+    specified materials from the same place.
+
+    e) Verify that the user has already received a copy of these
+    materials or that you have already sent this user a copy.
+
+  For an executable, the required form of the "work that uses the
+Library" must include any data and utility programs needed for
+reproducing the executable from it.  However, as a special exception,
+the materials to be distributed need not include anything that is
+normally distributed (in either source or binary form) with the major
+components (compiler, kernel, and so on) of the operating system on
+which the executable runs, unless that component itself accompanies
+the executable.
+
+  It may happen that this requirement contradicts the license
+restrictions of other proprietary libraries that do not normally
+accompany the operating system.  Such a contradiction means you cannot
+use both them and the Library together in an executable that you
+distribute.
+^L
+  7. You may place library facilities that are a work based on the
+Library side-by-side in a single library together with other library
+facilities not covered by this License, and distribute such a combined
+library, provided that the separate distribution of the work based on
+the Library and of the other library facilities is otherwise
+permitted, and provided that you do these two things:
+
+    a) Accompany the combined library with a copy of the same work
+    based on the Library, uncombined with any other library
+    facilities.  This must be distributed under the terms of the
+    Sections above.
+
+    b) Give prominent notice with the combined library of the fact
+    that part of it is a work based on the Library, and explaining
+    where to find the accompanying uncombined form of the same work.
+
+  8. You may not copy, modify, sublicense, link with, or distribute
+the Library except as expressly provided under this License.  Any
+attempt otherwise to copy, modify, sublicense, link with, or
+distribute the Library is void, and will automatically terminate your
+rights under this License.  However, parties who have received copies,
+or rights, from you under this License will not have their licenses
+terminated so long as such parties remain in full compliance.
+
+  9. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Library or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Library (or any work based on the
+Library), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Library or works based on it.
+
+  10. Each time you redistribute the Library (or any work based on the
+Library), the recipient automatically receives a license from the
+original licensor to copy, distribute, link with or modify the Library
+subject to these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties with
+this License.
+^L
+  11. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Library at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Library by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply, and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  12. If the distribution and/or use of the Library is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Library under this License
+may add an explicit geographical distribution limitation excluding those
+countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  13. The Free Software Foundation may publish revised and/or new
+versions of the Lesser General Public License from time to time.
+Such new versions will be similar in spirit to the present version,
+but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Library
+specifies a version number of this License which applies to it and
+"any later version", you have the option of following the terms and
+conditions either of that version or of any later version published by
+the Free Software Foundation.  If the Library does not specify a
+license version number, you may choose any version ever published by
+the Free Software Foundation.
+^L
+  14. If you wish to incorporate parts of the Library into other free
+programs whose distribution conditions are incompatible with these,
+write to the author to ask for permission.  For software which is
+copyrighted by the Free Software Foundation, write to the Free
+Software Foundation; we sometimes make exceptions for this.  Our
+decision will be guided by the two goals of preserving the free status
+of all derivatives of our free software and of promoting the sharing
+and reuse of software generally.
+
+                            NO WARRANTY
+
+  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
+LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGES.
+
+                     END OF TERMS AND CONDITIONS
+^L
+           How to Apply These Terms to Your New Libraries
+
+  If you develop a new library, and you want it to be of the greatest
+possible use to the public, we recommend making it free software that
+everyone can redistribute and change.  You can do so by permitting
+redistribution under these terms (or, alternatively, under the terms
+of the ordinary General Public License).
+
+  To apply these terms, attach the following notices to the library.
+It is safest to attach them to the start of each source file to most
+effectively convey the exclusion of warranty; and each file should
+have at least the "copyright" line and a pointer to where the full
+notice is found.
+
+
+    <one line to give the library's name and a brief idea of what it does.>
+    Copyright (C) <year>  <name of author>
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2.1 of the License, or (at your option) any later version.
+
+    This library is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
+

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/README
===================================================================
--- branches/trunk-reorg/thirdparty/puri-1.5.1/README	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/puri-1.5.1/README	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,46 @@
+PURI - Portable URI Library
+===========================
+
+AUTHORS
+-------
+Franz, Inc <http://www.franz.com>
+Kevin Rosenberg <kevin@rosenberg.net>
+
+
+DOWNLOAD
+--------
+Puri home: http://files.b9.com/puri/
+Portable tester home: http://files.b9.com/tester/
+
+
+SUPPORTED PLATFORMS
+-------------------
+   AllegroCL, CLISP, CMUCL, Lispworks, OpenMCL, SBCL
+
+
+OVERVIEW
+--------
+This is portable Universal Resource Identifier library for Common Lisp
+programs. It parses URI according to the RFC 2396 specification. It's
+is based on Franz, Inc's opensource URI package and has been ported to
+work other CL implementations. It is licensed under the LLGPL which
+is included in this distribution.
+
+A regression suite is included which uses Franz's open-source tester
+library. I've ported that library for use on other CL
+implementations. Puri completes 126/126 regression tests successfully.
+
+Franz's unmodified documentation file is included in the file
+uri.html. 
+
+
+DIFFERENCES BETWEEN PURI and NET.URI
+------------------------------------
+
+* Puri uses the package 'puri while NET.URI uses the package 'net.uri
+
+* To signal an error parsing a URI, Puri uses the condition
+  :uri-parse-error while NET.URI uses the condition :parse-error. This
+  divergence occurs because Franz's parse-error condition uses
+  :format-control and :format-arguments slots which are not in the ANSI
+  specification for the parse-error condition.

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/puri.asd
===================================================================
--- branches/trunk-reorg/thirdparty/puri-1.5.1/puri.asd	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/puri-1.5.1/puri.asd	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,33 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; Programmer: Kevin Rosenberg
+
+
+(in-package #:cl-user)
+(defpackage #:puri-system (:use #:cl #:asdf))
+(in-package #:puri-system)
+
+
+(defsystem puri
+  :name "cl-puri"
+  :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
+  :licence "GNU Lesser General Public License"
+  :description "Portable Universal Resource Indentifier Library"
+  :components
+  ((:file "src")))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'puri))))
+  (oos 'load-op 'puri-tests)
+  (oos 'test-op 'puri-tests))
+
+(defsystem puri-tests
+    :depends-on (:puri :ptester) 
+    :components
+    ((:file "tests")))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'puri-tests))))
+  (or (funcall (intern (symbol-name '#:do-tests)
+		       (find-package :puri-tests)))
+      (error "test-op failed")))
+
+(defmethod operation-done-p ((o test-op) (c (eql (find-system 'puri-tests))))
+  (values nil))

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/src.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/puri-1.5.1/src.lisp	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/puri-1.5.1/src.lisp	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,1419 @@
+;; -*- mode: common-lisp; package: puri -*-
+;; Support for URIs
+;; For general URI information see RFC2396.
+;;
+;; copyright (c) 1999-2002 Franz Inc, Berkeley, CA  - All rights reserved.
+;; copyright (c) 2002-2005 Franz Inc, Oakland, CA - All rights reserved.
+;; copyright (c) 2003-2006 Kevin Rosenberg (porting changes)
+;;
+;; This code is free software; you can redistribute it and/or
+;; modify it under the terms of the version 2.1 of
+;; the GNU Lesser General Public License as published by 
+;; the Free Software Foundation, as clarified by the
+;; preamble found here:
+;;     http://opensource.franz.com/preamble.html
+;;
+;; Versions ported from Franz's opensource release
+;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer
+;; uri.cl,v 2.9.84.1 2005/08/11 18:38:52 layer
+
+;; This code is distributed in the hope that it will be useful,
+;; but without any warranty; without even the implied warranty of
+;; merchantability or fitness for a particular purpose.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; $Id: src.lisp 11328 2006-12-02 15:43:07Z kevin $
+
+(defpackage #:puri
+  (:use #:cl)
+  #-allegro (:nicknames #:net.uri)
+  (:export
+   #:uri				; the type and a function
+   #:uri-p
+   #:copy-uri
+
+   #:uri-scheme				; and slots
+   #:uri-host #:uri-port
+   #:uri-path
+   #:uri-query
+   #:uri-fragment
+   #:uri-plist
+   #:uri-authority			; pseudo-slot accessor
+
+   #:urn				; class
+   #:urn-nid				; pseudo-slot accessor
+   #:urn-nss				; pseudo-slot accessor
+   
+   #:*strict-parse*
+   #:parse-uri
+   #:merge-uris
+   #:enough-uri
+   #:uri-parsed-path
+   #:render-uri
+
+   #:make-uri-space			; interning...
+   #:uri-space
+   #:uri=
+   #:intern-uri
+   #:unintern-uri
+   #:do-all-uris
+
+   #:uri-parse-error ;; Added by KMR
+   ))
+
+(in-package #:puri)
+
+(eval-when (:compile-toplevel) (declaim (optimize (speed 3))))
+
+
+#-allegro
+(defun parse-body (forms &optional env)
+  "Parses a body, returns (VALUES docstring declarations forms)"
+  (declare (ignore env))
+  ;; fixme -- need to add parsing of multiple declarations
+  (let (docstring declarations)
+    (when (stringp (car forms))
+      (setq docstring (car forms))
+      (setq forms (cdr forms)))
+    (when (and (listp (car forms))
+	       (symbolp (caar forms))
+	       (string-equal (symbol-name '#:declare)
+			     (symbol-name (caar forms))))
+      (setq declarations (car forms))
+      (setq forms (cdr forms)))
+    (values docstring declarations forms)))
+
+  
+(defun shrink-vector (str size)
+  #+allegro
+  (excl::.primcall 'sys::shrink-svector str size)
+  #+sbcl
+  (setq str (sb-kernel:shrink-vector str size))
+  #+cmu
+  (lisp::shrink-vector str size)
+  #+lispworks
+  (system::shrink-vector$vector str size)
+  #+scl
+  (common-lisp::shrink-vector str size)
+  #-(or allegro cmu lispworks sbcl scl)
+  (setq str (subseq str 0 size))
+  str)
+
+
+;; KMR: Added new condition to handle cross-implementation variances
+;; in the parse-error condition many implementations define
+
+(define-condition uri-parse-error (parse-error)
+  ((fmt-control :initarg :fmt-control :accessor fmt-control)
+   (fmt-arguments :initarg :fmt-arguments :accessor fmt-arguments ))
+  (:report (lambda (c stream)
+	     (format stream "Parse error:")
+	     (apply #'format stream (fmt-control c) (fmt-arguments c)))))
+
+(defun .parse-error (fmt &rest args)
+  (error 'uri-parse-error :fmt-control fmt :fmt-arguments args))
+
+#-allegro
+(defun internal-reader-error (stream fmt &rest args)
+  (apply #'format stream fmt args))
+
+#-allegro (defvar *current-case-mode* :case-insensitive-upper)
+#+allegro (eval-when (:compile-toplevel :load-toplevel :execute)
+	    (import '(excl:*current-case-mode*
+		      excl:delimited-string-to-list
+		      excl::parse-body
+		      excl::internal-reader-error
+		      excl:if*)))
+
+#-allegro
+(defmethod position-char (char (string string) start max)
+  (declare (optimize (speed 3) (safety 0) (space 0))
+	   (fixnum start max) (string string))
+  (do* ((i start (1+ i)))
+       ((= i max) nil)
+    (declare (fixnum i))
+    (when (char= char (char string i)) (return i))))
+
+#-allegro 
+(defun delimited-string-to-list (string &optional (separator #\space) 
+                                        skip-terminal)
+  (declare (optimize (speed 3) (safety 0) (space 0)
+		     (compilation-speed 0))
+	   (type string string)
+	   (type character separator))
+  (do* ((len (length string))
+	(output '())
+	(pos 0)
+	(end (position-char separator string pos len)
+	     (position-char separator string pos len)))
+       ((null end)
+	(if (< pos len)
+	    (push (subseq string pos) output)
+          (when (and (plusp len) (not skip-terminal))
+            (push "" output)))
+        (nreverse output))
+    (declare (type fixnum pos len)
+	     (type (or null fixnum) end))
+    (push (subseq string pos end) output)
+    (setq pos (1+ end))))
+
+#-allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar if*-keyword-list '("then" "thenret" "else" "elseif"))
+
+  (defmacro if* (&rest args)
+    (do ((xx (reverse args) (cdr xx))
+	 (state :init)
+	 (elseseen nil)
+	 (totalcol nil)
+	(lookat nil nil)
+	 (col nil))
+	((null xx)
+	 (cond ((eq state :compl)
+		`(cond ,@totalcol))
+	       (t (error "if*: illegal form ~s" args))))
+      (cond ((and (symbolp (car xx))
+		  (member (symbol-name (car xx))
+			  if*-keyword-list
+			  :test #'string-equal))
+	     (setq lookat (symbol-name (car xx)))))
+
+       (cond ((eq state :init)
+	      (cond (lookat (cond ((string-equal lookat "thenret")
+				   (setq col nil
+					 state :then))
+				  (t (error
+				      "if*: bad keyword ~a" lookat))))
+		    (t (setq state :col
+			     col nil)
+		       (push (car xx) col))))
+	     ((eq state :col)
+	      (cond (lookat
+		     (cond ((string-equal lookat "else")
+			    (cond (elseseen
+				   (error
+				    "if*: multiples elses")))
+			    (setq elseseen t)
+			    (setq state :init)
+			    (push `(t ,@col) totalcol))
+			   ((string-equal lookat "then")
+			    (setq state :then))
+			   (t (error "if*: bad keyword ~s"
+					      lookat))))
+		    (t (push (car xx) col))))
+	     ((eq state :then)
+	      (cond (lookat
+		     (error
+		      "if*: keyword ~s at the wrong place " (car xx)))
+		    (t (setq state :compl)
+		       (push `(,(car xx) ,@col) totalcol))))
+	     ((eq state :compl)
+	      (cond ((not (string-equal lookat "elseif"))
+		     (error "if*: missing elseif clause ")))
+	      (setq state :init))))))
+
+
+(defclass uri ()
+  (
+;;;; external:
+   (scheme :initarg :scheme :initform nil :accessor uri-scheme)
+   (host :initarg :host :initform nil :accessor uri-host)
+   (port :initarg :port :initform nil :accessor uri-port)
+   (path :initarg :path :initform nil :accessor uri-path)
+   (query :initarg :query :initform nil :accessor uri-query)
+   (fragment :initarg :fragment :initform nil :accessor uri-fragment)
+   (plist :initarg :plist :initform nil :accessor uri-plist)
+
+;;;; internal:
+   (escaped
+    ;; used to prevent unnessary work, looking for chars to escape and
+    ;; unescape.
+    :initarg :escaped :initform nil :accessor uri-escaped)
+   (string
+    ;; the cached printable representation of the URI.  It *might* be
+    ;; different than the original string, though, because the user might
+    ;; have escaped non-reserved chars--they won't be escaped when the URI
+    ;; is printed.
+    :initarg :string :initform nil :accessor uri-string)
+   (parsed-path
+    ;; the cached parsed representation of the URI path.
+    :initarg :parsed-path
+    :initform nil
+    :accessor .uri-parsed-path)
+   (hashcode
+    ;; cached sxhash, so we don't have to compute it more than once.
+    :initarg :hashcode :initform nil :accessor uri-hashcode)))
+
+(defclass urn (uri)
+  ((nid :initarg :nid :initform nil :accessor urn-nid)
+   (nss :initarg :nss :initform nil :accessor urn-nss)))
+
+(eval-when (:compile-toplevel :execute)
+  (defmacro clear-caching-on-slot-change (name)
+    `(defmethod (setf ,name) :around (new-value (self uri))
+       (declare (ignore new-value))
+       (prog1 (call-next-method)
+	 (setf (uri-string self) nil)
+	 ,@(when (eq name 'uri-path) `((setf (.uri-parsed-path self) nil)))
+	 (setf (uri-hashcode self) nil))))
+  )
+
+(clear-caching-on-slot-change uri-scheme)
+(clear-caching-on-slot-change uri-host)
+(clear-caching-on-slot-change uri-port)
+(clear-caching-on-slot-change uri-path)
+(clear-caching-on-slot-change uri-query)
+(clear-caching-on-slot-change uri-fragment)
+
+
+(defmethod make-load-form ((self uri) &optional env)
+  (declare (ignore env))
+  `(make-instance ',(class-name (class-of self))
+     :scheme ,(uri-scheme self)
+     :host ,(uri-host self)
+     :port ,(uri-port self)
+     :path ',(uri-path self)
+     :query ,(uri-query self)
+     :fragment ,(uri-fragment self)
+     :plist ',(uri-plist self)
+     :string ,(uri-string self)
+     :parsed-path ',(.uri-parsed-path self)))
+
+(defmethod uri-p ((thing uri)) t)
+(defmethod uri-p ((thing t)) nil)
+
+(defun copy-uri (uri
+		 &key place
+		      (scheme (when uri (uri-scheme uri)))
+		      (host (when uri (uri-host uri)))
+		      (port (when uri (uri-port uri)))
+		      (path (when uri (uri-path uri)))
+		      (parsed-path
+		       (when uri (copy-list (.uri-parsed-path uri))))
+		      (query (when uri (uri-query uri)))
+		      (fragment (when uri (uri-fragment uri)))
+		      (plist (when uri (copy-list (uri-plist uri))))
+		      (class (when uri (class-of uri)))
+		 &aux (escaped (when uri (uri-escaped uri))))
+  (if* place
+     then (setf (uri-scheme place) scheme)
+	  (setf (uri-host place) host)
+	  (setf (uri-port place) port)
+	  (setf (uri-path place) path)
+	  (setf (.uri-parsed-path place) parsed-path)
+	  (setf (uri-query place) query)
+	  (setf (uri-fragment place) fragment)
+	  (setf (uri-plist place) plist)
+	  (setf (uri-escaped place) escaped)
+	  (setf (uri-string place) nil)
+	  (setf (uri-hashcode place) nil)
+	  place
+   elseif (eq 'uri class)
+     then ;; allow the compiler to optimize the call to make-instance:
+	  (make-instance 'uri
+	    :scheme scheme :host host :port port :path path
+	    :parsed-path parsed-path
+	    :query query :fragment fragment :plist plist
+	    :escaped escaped :string nil :hashcode nil)
+     else (make-instance class
+	    :scheme scheme :host host :port port :path path
+	    :parsed-path parsed-path
+	    :query query :fragment fragment :plist plist
+	    :escaped escaped :string nil :hashcode nil)))
+
+(defmethod uri-parsed-path ((uri uri))
+  (when (uri-path uri)
+    (when (null (.uri-parsed-path uri))
+      (setf (.uri-parsed-path uri)
+	(parse-path (uri-path uri) (uri-escaped uri))))
+    (.uri-parsed-path uri)))
+
+(defmethod (setf uri-parsed-path) (path-list (uri uri))
+  (assert (and (consp path-list)
+	       (or (member (car path-list) '(:absolute :relative)
+			   :test #'eq))))
+  (setf (uri-path uri) (render-parsed-path path-list t))
+  (setf (.uri-parsed-path uri) path-list)
+  path-list)
+
+(defun uri-authority (uri)
+  (when (uri-host uri)
+    (let ((*print-pretty* nil))
+      (format nil "~a~@[:~a~]" (uri-host uri) (uri-port uri)))))
+
+(defun uri-nid (uri)
+  (if* (equalp "urn" (uri-scheme uri))
+     then (uri-host uri)
+     else (error "URI is not a URN: ~s." uri)))
+
+(defun uri-nss (uri)
+  (if* (equalp "urn" (uri-scheme uri))
+     then (uri-path uri)
+     else (error "URI is not a URN: ~s." uri)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Parsing
+
+(defparameter *excluded-characters*
+    '(;; `delims' (except #\%, because it's handled specially):
+      #\< #\> #\" #\space #\#
+      ;; `unwise':
+      #\{ #\} #\| #\\ #\^ #\[ #\] #\`))
+
+(defun reserved-char-vector (chars &key except)
+  (do* ((a (make-array 127 :element-type 'bit :initial-element 0))
+	(chars chars (cdr chars))
+	(c (car chars) (car chars)))
+      ((null chars) a)
+    (if* (and except (member c except :test #'char=))
+       thenret
+       else (setf (sbit a (char-int c)) 1))))
+
+(defparameter *reserved-characters*
+    (reserved-char-vector
+     (append *excluded-characters*
+	     '(#\; #\/ #\? #\: #\@ #\& #\= #\+ #\$ #\, #\%))))
+(defparameter *reserved-authority-characters*
+    (reserved-char-vector
+     (append *excluded-characters* '(#\; #\/ #\? #\: #\@))))
+(defparameter *reserved-path-characters*
+    (reserved-char-vector
+     (append *excluded-characters*
+	     '(#\;
+;;;;The rfc says this should be here, but it doesn't make sense.
+	       ;; #\=
+	       #\/ #\?))))
+
+(defparameter *reserved-fragment-characters*
+    (reserved-char-vector (remove #\# *excluded-characters*)))
+
+(eval-when (:compile-toplevel :execute)
+(defun gen-char-range-list (start end)
+  (do* ((res '())
+	(endcode (1+ (char-int end)))
+	(chcode (char-int start)
+		(1+ chcode))
+	(hyphen nil))
+      ((= chcode endcode)
+       ;; - has to be first, otherwise it signifies a range!
+       (if* hyphen
+	  then (setq res (nreverse res))
+	       (push #\- res)
+	       res
+	  else (nreverse res)))
+    (if* (= #.(char-int #\-) chcode)
+       then (setq hyphen t)
+       else (push (code-char chcode) res))))
+)
+
+(defparameter *valid-nid-characters*
+    (reserved-char-vector
+     '#.(nconc (gen-char-range-list #\a #\z)
+	       (gen-char-range-list #\A #\Z)
+	       (gen-char-range-list #\0 #\9)
+	       '(#\- #\. #\+))))
+(defparameter *reserved-nss-characters*
+    (reserved-char-vector
+     (append *excluded-characters* '(#\& #\~ #\/ #\?))))
+
+(defparameter *illegal-characters*
+    (reserved-char-vector (remove #\# *excluded-characters*)))
+(defparameter *strict-illegal-query-characters*
+    (reserved-char-vector (append '(#\?) (remove #\# *excluded-characters*))))
+(defparameter *illegal-query-characters*
+    (reserved-char-vector
+     *excluded-characters* :except '(#\^ #\| #\#)))
+
+
+(defun parse-uri (thing &key (class 'uri) &aux escape)
+  (when (uri-p thing) (return-from parse-uri thing))
+  
+  (setq escape (escape-p thing))
+  (multiple-value-bind (scheme host port path query fragment)
+      (parse-uri-string thing)
+    (when scheme
+      (setq scheme
+	(intern (funcall
+		 (case *current-case-mode*
+		   ((:case-insensitive-upper :case-sensitive-upper)
+		    #'string-upcase)
+		   ((:case-insensitive-lower :case-sensitive-lower)
+		    #'string-downcase))
+		 (decode-escaped-encoding scheme escape))
+		(find-package :keyword))))
+    
+    (when (and scheme (eq :urn scheme))
+      (return-from parse-uri
+	(make-instance 'urn :scheme scheme :nid host :nss path)))
+    
+    (when host (setq host (decode-escaped-encoding host escape)))
+    (when port
+      (setq port (read-from-string port))
+      (when (not (numberp port)) (error "port is not a number: ~s." port))
+      (when (not (plusp port))
+	(error "port is not a positive integer: ~d." port))
+      (when (eql port (case scheme
+		      (:http 80)
+		      (:https 443)
+		      (:ftp 21)
+		      (:telnet 23)))
+	(setq port nil)))
+    (when (or (string= "" path)
+	      (and ;; we canonicalize away a reference to just /:
+	       scheme
+	       (member scheme '(:http :https :ftp) :test #'eq)
+	       (string= "/" path)))
+      (setq path nil))
+    (when path
+      (setq path
+	(decode-escaped-encoding path escape *reserved-path-characters*)))
+    (when query (setq query (decode-escaped-encoding query escape)))
+    (when fragment
+      (setq fragment
+	(decode-escaped-encoding fragment escape
+				 *reserved-fragment-characters*)))
+    (if* (eq 'uri class)
+       then ;; allow the compiler to optimize the make-instance call:
+	    (make-instance 'uri
+	      :scheme scheme
+	      :host host
+	      :port port
+	      :path path
+	      :query query
+	      :fragment fragment
+	      :escaped escape)
+       else ;; do it the slow way:
+	    (make-instance class
+	      :scheme scheme
+	      :host host
+	      :port port
+	      :path path
+	      :query query
+	      :fragment fragment
+	      :escaped escape))))
+
+(defmethod uri ((thing uri))
+  thing)
+
+(defmethod uri ((thing string))
+  (parse-uri thing))
+
+(defmethod uri ((thing t))
+  (error "Cannot coerce ~s to a uri." thing))
+
+(defvar *strict-parse* t)
+
+(defun parse-uri-string (string &aux (illegal-chars *illegal-characters*))
+  (declare (optimize (speed 3)))
+  ;; Speed is important, so use a specialized state machine instead of
+  ;; regular expressions for parsing the URI string. The regexp we are
+  ;; simulating:
+  ;;  ^(([^:/?#]+):)?
+  ;;   (//([^/?#]*))?
+  ;;   ([^?#]*)
+  ;;   (\?([^#]*))?
+  ;;   (#(.*))?
+  (let* ((state 0)
+	 (start 0)
+	 (end (length string))
+	 (tokval nil)
+	 (scheme nil)
+	 (host nil)
+	 (port nil)
+	 (path-components '())
+	 (query nil)
+	 (fragment nil)
+	 ;; namespace identifier, for urn parsing only:
+	 (nid nil))
+    (declare (fixnum state start end))
+    (flet ((read-token (kind &optional legal-chars)
+	     (setq tokval nil)
+	     (if* (>= start end)
+		then :end
+		else (let ((sindex start)
+			   (res nil)
+			   c)
+		       (declare (fixnum sindex))
+		       (setq res
+			 (loop
+			   (when (>= start end) (return nil))
+			   (setq c (char string start))
+			   (let ((ci (char-int c)))
+			     (if* legal-chars
+				then (if* (and (eq :colon kind) (eq c #\:))
+					then (return :colon)
+				      elseif (= 0 (sbit legal-chars ci))
+					then (.parse-error
+					      "~
+URI ~s contains illegal character ~s at position ~d."
+					      string c start))
+			      elseif (and (< ci 128)
+					  *strict-parse*
+					  (= 1 (sbit illegal-chars ci)))
+				then (.parse-error "~
+URI ~s contains illegal character ~s at position ~d."
+							 string c start)))
+			   (case kind
+			     (:path (case c
+				      (#\? (return :question))
+				      (#\# (return :hash))))
+			     (:query (case c (#\# (return :hash))))
+			     (:rest)
+			     (t (case c
+				  (#\: (return :colon))
+				  (#\? (return :question))
+				  (#\# (return :hash))
+				  (#\/ (return :slash)))))
+			   (incf start)))
+		       (if* (> start sindex)
+			  then ;; we found some chars
+			       ;; before we stopped the parse
+			       (setq tokval (subseq string sindex start))
+			       :string
+			  else ;; immediately stopped at a special char
+			       (incf start)
+			       res))))
+	   (failure (&optional why)
+	     (.parse-error "illegal URI: ~s [~d]~@[: ~a~]"
+				 string state why))
+	   (impossible ()
+	     (.parse-error "impossible state: ~d [~s]" state string)))
+      (loop
+	(case state
+	  (0 ;; starting to parse
+	   (ecase (read-token t)
+	     (:colon (failure))
+	     (:question (setq state 7))
+	     (:hash (setq state 8))
+	     (:slash (setq state 3))
+	     (:string (setq state 1))
+	     (:end (setq state 9))))
+	  (1 ;; seen <token><special char>
+	   (let ((token tokval))
+	     (ecase (read-token t)
+	       (:colon (setq scheme token)
+		       (if* (equalp "urn" scheme)
+			  then (setq state 15)
+			  else (setq state 2)))
+	       (:question (push token path-components)
+			  (setq state 7))
+	       (:hash (push token path-components)
+		      (setq state 8))
+	       (:slash (push token path-components)
+		       (push "/" path-components)
+		       (setq state 6))
+	       (:string (failure))
+	       (:end (push token path-components)
+		     (setq state 9)))))
+	  (2 ;; seen <scheme>:
+	   (ecase (read-token t)
+	     (:colon (failure))
+	     (:question (setq state 7))
+	     (:hash (setq state 8))
+	     (:slash (setq state 3))
+	     (:string (setq state 10))
+	     (:end (setq state 9))))
+	  (10 ;; seen <scheme>:<token>
+	   (let ((token tokval))
+	     (ecase (read-token t)
+	       (:colon (failure))
+	       (:question (push token path-components)
+			  (setq state 7))
+	       (:hash (push token path-components)
+		      (setq state 8))
+	       (:slash (push token path-components)
+		       (setq state 6))
+	       (:string (failure))
+	       (:end (push token path-components)
+		     (setq state 9)))))
+	  (3 ;; seen / or <scheme>:/
+	   (ecase (read-token t)
+	     (:colon (failure))
+	     (:question (push "/" path-components)
+			(setq state 7))
+	     (:hash (push "/" path-components)
+		    (setq state 8))
+	     (:slash (setq state 4))
+	     (:string (push "/" path-components)
+		      (push tokval path-components)
+		      (setq state 6))
+	     (:end (push "/" path-components)
+		   (setq state 9))))
+	  (4 ;; seen [<scheme>:]//
+	   (ecase (read-token t)
+	     (:colon (failure))
+	     (:question (failure))
+	     (:hash (failure))
+	     (:slash
+	      (if* (and (equalp "file" scheme)
+			(null host))
+		 then ;; file:///...
+		      (push "/" path-components)
+		      (setq state 6)
+		 else (failure)))
+	     (:string (setq host tokval)
+		      (setq state 11))
+	     (:end (failure))))
+	  (11 ;; seen [<scheme>:]//<host>
+	   (ecase (read-token t)
+	     (:colon (setq state 5))
+	     (:question (setq state 7))
+	     (:hash (setq state 8))
+	     (:slash (push "/" path-components)
+		     (setq state 6))
+	     (:string (impossible))
+	     (:end (setq state 9))))
+	  (5 ;; seen [<scheme>:]//<host>:
+	   (ecase (read-token t)
+	     (:colon (failure))
+	     (:question (failure))
+	     (:hash (failure))
+	     (:slash (push "/" path-components)
+		     (setq state 6))
+	     (:string (setq port tokval)
+		      (setq state 12))
+	     (:end (failure))))
+	  (12 ;; seen [<scheme>:]//<host>:[<port>]
+	   (ecase (read-token t)
+	     (:colon (failure))
+	     (:question (setq state 7))
+	     (:hash (setq state 8))
+	     (:slash (push "/" path-components)
+		     (setq state 6))
+	     (:string (impossible))
+	     (:end (setq state 9))))
+	  (6 ;; seen /
+	   (ecase (read-token :path)
+	     (:question (setq state 7))
+	     (:hash (setq state 8))
+	     (:string (push tokval path-components)
+		      (setq state 13))
+	     (:end (setq state 9))))
+	  (13 ;; seen path
+	   (ecase (read-token :path)
+	     (:question (setq state 7))
+	     (:hash (setq state 8))
+	     (:string (impossible))
+	     (:end (setq state 9))))
+	  (7 ;; seen ?
+	   (setq illegal-chars
+	     (if* *strict-parse*
+		then *strict-illegal-query-characters*
+		else *illegal-query-characters*))
+	   (ecase (prog1 (read-token :query)
+		    (setq illegal-chars *illegal-characters*))
+	     (:hash (setq state 8))
+	     (:string (setq query tokval)
+		      (setq state 14))
+	     (:end (setq state 9))))
+	  (14 ;; query
+	   (ecase (read-token :query)
+	     (:hash (setq state 8))
+	     (:string (impossible))
+	     (:end (setq state 9))))
+	  (8 ;; seen #
+	   (ecase (read-token :rest)
+	     (:string (setq fragment tokval)
+		      (setq state 9))
+	     (:end (setq state 9))))
+	  (9 ;; done
+	   (return
+	     (values
+	      scheme host port
+	      (apply #'concatenate 'string (nreverse path-components))
+	      query fragment)))
+	  ;; URN parsing:
+	  (15 ;; seen urn:, read nid now
+	   (case (read-token :colon *valid-nid-characters*)
+	     (:string (setq nid tokval)
+		      (setq state 16))
+	     (t (failure "missing namespace identifier"))))
+	  (16 ;; seen urn:<nid>
+	   (case (read-token t)
+	     (:colon (setq state 17))
+	     (t (failure "missing namespace specific string"))))
+	  (17 ;; seen urn:<nid>:, rest is nss
+	   (return (values scheme
+			   nid
+			   nil
+			   (progn
+			     (setq illegal-chars *reserved-nss-characters*)
+			     (read-token :rest)
+			     tokval))))
+	  (t (.parse-error
+	      "internal error in parse engine, wrong state: ~s." state)))))))
+
+(defun escape-p (string)
+  (declare (optimize (speed 3)))
+  (do* ((i 0 (1+ i))
+	(max (the fixnum (length string))))
+      ((= i max) nil)
+    (declare (fixnum i max))
+    (when (char= #\% (char string i))
+      (return t))))
+
+(defun parse-path (path-string escape)
+  (do* ((xpath-list (delimited-string-to-list path-string #\/))
+	(path-list
+	 (progn
+	   (if* (string= "" (car xpath-list))
+	      then (setf (car xpath-list) :absolute)
+	      else (push :relative xpath-list))
+	   xpath-list))
+	(pl (cdr path-list) (cdr pl))
+	segments)
+      ((null pl) path-list)
+    
+    (if* (cdr (setq segments
+		(if* (string= "" (car pl))
+		   then '("")
+		   else (delimited-string-to-list (car pl) #\;))))
+       then ;; there is a param
+	    (setf (car pl)
+	      (mapcar #'(lambda (s)
+			  (decode-escaped-encoding s escape
+						   ;; decode all %xx:
+						   nil))
+		      segments))
+       else ;; no param
+	    (setf (car pl)
+	      (decode-escaped-encoding (car segments) escape
+				       ;; decode all %xx:
+				       nil)))))
+
+(defun decode-escaped-encoding (string escape
+				&optional (reserved-chars
+					   *reserved-characters*))
+  ;; Return a string with the real characters.
+  (when (null escape) (return-from decode-escaped-encoding string))
+  (do* ((i 0 (1+ i))
+	(max (length string))
+	(new-string (copy-seq string))
+	(new-i 0 (1+ new-i))
+	ch ch2 chc chc2)
+      ((= i max)
+       (shrink-vector new-string new-i))
+    (if* (char= #\% (setq ch (char string i)))
+       then (when (> (+ i 3) max)
+	      (.parse-error
+	       "Unsyntactic escaped encoding in ~s." string))
+	    (setq ch (char string (incf i)))
+	    (setq ch2 (char string (incf i)))
+	    (when (not (and (setq chc (digit-char-p ch 16))
+			    (setq chc2 (digit-char-p ch2 16))))
+	      (.parse-error
+	       "Non-hexidecimal digits after %: %c%c." ch ch2))
+	    (let ((ci (+ (* 16 chc) chc2)))
+	      (if* (or (null reserved-chars)
+		       (> ci 127)	; bug11527
+		       (= 0 (sbit reserved-chars ci)))
+		 then ;; ok as is
+		      (setf (char new-string new-i)
+			(code-char ci))
+		 else (setf (char new-string new-i) #\%)
+		      (setf (char new-string (incf new-i)) ch)
+		      (setf (char new-string (incf new-i)) ch2)))
+       else (setf (char new-string new-i) ch))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Printing
+
+(defun render-uri (uri stream
+		   &aux (escape (uri-escaped uri))
+			(*print-pretty* nil))
+  (when (null (uri-string uri))
+    (setf (uri-string uri)
+      (let ((scheme (uri-scheme uri))
+	    (host (uri-host uri))
+	    (port (uri-port uri))
+	    (path (uri-path uri))
+	    (query (uri-query uri))
+	    (fragment (uri-fragment uri)))
+	(concatenate 'string
+	  (when scheme
+	    (encode-escaped-encoding
+	     (string-downcase ;; for upper case lisps
+	      (symbol-name scheme))
+	     *reserved-characters* escape))
+	  (when scheme ":")
+	  (when (or host (eq :file scheme)) "//")
+	  (when host
+	    (encode-escaped-encoding
+	     host *reserved-authority-characters* escape))
+	  (when port ":")
+	  (when port
+	    #-allegro (format nil "~D" port)
+	    #+allegro (with-output-to-string (s)
+			(excl::maybe-print-fast s port))
+	    )
+	  (when path
+	    (encode-escaped-encoding path
+				     nil
+				     ;;*reserved-path-characters*
+				     escape))
+	  (when query "?")
+	  (when query (encode-escaped-encoding query nil escape))
+	  (when fragment "#")
+	  (when fragment (encode-escaped-encoding fragment nil escape))))))
+  (if* stream
+     then (format stream "~a" (uri-string uri))
+     else (uri-string uri)))
+
+(defun render-parsed-path (path-list escape)
+  (do* ((res '())
+	(first (car path-list))
+	(pl (cdr path-list) (cdr pl))
+	(pe (car pl) (car pl)))
+      ((null pl)
+       (when res (apply #'concatenate 'string (nreverse res))))
+    (when (or (null first)
+	      (prog1 (eq :absolute first)
+		(setq first nil)))
+      (push "/" res))
+    (if* (atom pe)
+       then (push
+	     (encode-escaped-encoding pe *reserved-path-characters* escape)
+	     res)
+       else ;; contains params
+	    (push (encode-escaped-encoding
+		   (car pe) *reserved-path-characters* escape)
+		  res)
+	    (dolist (item (cdr pe))
+	      (push ";" res)
+	      (push (encode-escaped-encoding
+		     item *reserved-path-characters* escape)
+		    res)))))
+
+(defun render-urn (urn stream
+		   &aux (*print-pretty* nil))
+  (when (null (uri-string urn))
+    (setf (uri-string urn)
+      (let ((nid (urn-nid urn))
+	    (nss (urn-nss urn)))
+	(concatenate 'string "urn:" nid ":" nss))))
+  (if* stream
+     then (format stream "~a" (uri-string urn))
+     else (uri-string urn)))
+
+(defparameter *escaped-encoding*
+    (vector #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\f))
+
+(defun encode-escaped-encoding (string reserved-chars escape)
+  (when (null escape) (return-from encode-escaped-encoding string))
+  ;; Make a string as big as it possibly needs to be (3 times the original
+  ;; size), and truncate it at the end.
+  (do* ((max (length string))
+	(new-max (* 3 max)) ;; worst case new size
+	(new-string (make-string new-max))
+	(i 0 (1+ i))
+	(new-i -1)
+	c ci)
+      ((= i max)
+       (shrink-vector new-string (incf new-i)))
+    (setq ci (char-int (setq c (char string i))))
+    (if* (or (null reserved-chars)
+	     (> ci 127)
+	     (= 0 (sbit reserved-chars ci)))
+       then ;; ok as is
+	    (incf new-i)
+	    (setf (char new-string new-i) c)
+       else ;; need to escape it
+	    (multiple-value-bind (q r) (truncate ci 16)
+	      (setf (char new-string (incf new-i)) #\%)
+	      (setf (char new-string (incf new-i)) (elt *escaped-encoding* q))
+	      (setf (char new-string (incf new-i))
+		(elt *escaped-encoding* r))))))
+
+(defmethod print-object ((uri uri) stream)
+  (if* *print-escape*
+     then (print-unreadable-object (uri stream :type t) (render-uri uri stream))
+     else (render-uri uri stream)))
+
+(defmethod print-object ((urn urn) stream)
+  (if* *print-escape*
+     then (print-unreadable-object (urn stream :type t) (render-urn urn stream))
+     else (render-urn urn stream)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; merging and unmerging
+
+(defmethod merge-uris ((uri string) (base string) &optional place)
+  (merge-uris (parse-uri uri) (parse-uri base) place))
+
+(defmethod merge-uris ((uri uri) (base string) &optional place)
+  (merge-uris uri (parse-uri base) place))
+
+(defmethod merge-uris ((uri string) (base uri) &optional place)
+  (merge-uris (parse-uri uri) base place))
+
+
+(defmethod merge-uris ((uri uri) (base uri) &optional place)
+  ;; See ../doc/rfc2396.txt for info on the algorithm we use to merge
+  ;; URIs.
+  ;;
+  (tagbody
+;;;; step 2
+    (when (and (null (uri-parsed-path uri))
+	       (null (uri-scheme uri))
+	       (null (uri-host uri))
+	       (null (uri-port uri))
+	       (null (uri-query uri)))
+      (return-from merge-uris
+	(let ((new (copy-uri base :place place)))
+	  (when (uri-query uri)
+	    (setf (uri-query new) (uri-query uri)))
+	  (when (uri-fragment uri)
+	    (setf (uri-fragment new) (uri-fragment uri)))
+	  new)))
+    
+    (setq uri (copy-uri uri :place place))
+
+;;;; step 3
+    (when (uri-scheme uri)
+      (return-from merge-uris uri))
+    (setf (uri-scheme uri) (uri-scheme base))
+  
+;;;; step 4
+    (when (uri-host uri) (go :done))
+    (setf (uri-host uri) (uri-host base))
+    (setf (uri-port uri) (uri-port base))
+    
+;;;; step 5
+    (let ((p (uri-parsed-path uri)))
+      
+      ;; bug13133:
+      ;; The following form causes our implementation to be at odds with
+      ;; RFC 2396, however this is apparently what was intended by the
+      ;; authors of the RFC.  Specifically, (merge-uris "?y" "/foo")
+      ;; should return #<uri /foo?y> instead of #<uri ?y>, according to
+      ;; this:
+;;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query
+      (when (null p)
+	(setf (uri-path uri) (uri-path base))
+	(go :done))
+      
+      (when (and p (eq :absolute (car p)))
+	(when (equal '(:absolute "") p)
+	  ;; Canonicalize the way parsing does:
+	  (setf (uri-path uri) nil))
+	(go :done)))
+    
+;;;; step 6
+    (let* ((base-path
+	    (or (uri-parsed-path base)
+		;; needed because we canonicalize away a path of just `/':
+		'(:absolute "")))
+	   (path (uri-parsed-path uri))
+	   new-path-list)
+      (when (not (eq :absolute (car base-path)))
+	(error "Cannot merge ~a and ~a, since latter is not absolute."
+	       uri base))
+
+      ;; steps 6a and 6b:
+      (setq new-path-list
+	(append (butlast base-path)
+		(if* path then (cdr path) else '(""))))
+
+      ;; steps 6c and 6d:
+      (let ((last (last new-path-list)))
+	(if* (atom (car last))
+	   then (when (string= "." (car last))
+		  (setf (car last) ""))
+	   else (when (string= "." (caar last))
+		  (setf (caar last) ""))))
+      (setq new-path-list
+	(delete "." new-path-list :test #'(lambda (a b)
+					    (if* (atom b)
+					       then (string= a b)
+					       else nil))))
+
+      ;; steps 6e and 6f:
+      (let ((npl (cdr new-path-list))
+	    index tmp fix-tail)
+	(setq fix-tail
+	  (string= ".." (let ((l (car (last npl))))
+			  (if* (atom l)
+			     then l
+			     else (car l)))))
+	(loop
+	  (setq index
+	    (position ".." npl
+		      :test #'(lambda (a b)
+				(string= a
+					 (if* (atom b)
+					    then b
+					    else (car b))))))
+	  (when (null index) (return))
+	  (when (= 0 index)
+	    ;; The RFC says, in 6g, "that the implementation may handle
+	    ;; this error by retaining these components in the resolved
+	    ;; path, by removing them from the resolved path, or by
+	    ;; avoiding traversal of the reference."  The examples in C.2
+	    ;; imply that we should do the first thing (retain them), so
+	    ;; that's what we'll do.
+	    (return))
+	  (if* (= 1 index)
+	     then (setq npl (cddr npl))
+	     else (setq tmp npl)
+		  (dotimes (x (- index 2)) (setq tmp (cdr tmp)))
+		  (setf (cdr tmp) (cdddr tmp))))
+	(setf (cdr new-path-list) npl)
+	(when fix-tail (setq new-path-list (nconc new-path-list '("")))))
+
+      ;; step 6g:
+      ;; don't complain if new-path-list starts with `..'.  See comment
+      ;; above about this step.
+
+      ;; step 6h:
+      (when (or (equal '(:absolute "") new-path-list)
+		(equal '(:absolute) new-path-list))
+	(setq new-path-list nil))
+      (setf (uri-path uri)
+	(render-parsed-path new-path-list
+			    ;; don't know, so have to assume:
+			    t)))
+
+;;;; step 7
+   :done
+    (return-from merge-uris uri)))
+
+(defmethod enough-uri ((uri string) (base string) &optional place)
+  (enough-uri (parse-uri uri) (parse-uri base) place))
+
+(defmethod enough-uri ((uri uri) (base string) &optional place)
+  (enough-uri uri (parse-uri base) place))
+
+(defmethod enough-uri ((uri string) (base uri) &optional place)
+  (enough-uri (parse-uri uri) base place))
+
+(defmethod enough-uri ((uri uri) (base uri) &optional place)
+  (let ((new-scheme nil)
+	(new-host nil)
+	(new-port nil)
+	(new-parsed-path nil))
+
+    (when (or (and (uri-scheme uri)
+		   (not (equalp (uri-scheme uri) (uri-scheme base))))
+	      (and (uri-host uri)
+		   (not (equalp (uri-host uri) (uri-host base))))
+	      (not (equalp (uri-port uri) (uri-port base))))
+      (return-from enough-uri uri))
+
+    (when (null (uri-host uri))
+      (setq new-host (uri-host base)))
+    (when (null (uri-port uri))
+      (setq new-port (uri-port base)))
+    
+    (when (null (uri-scheme uri))
+      (setq new-scheme (uri-scheme base)))
+
+    ;; Now, for the hard one, path.
+    ;; We essentially do here what enough-namestring does.
+    (do* ((base-path (uri-parsed-path base))
+	  (path (uri-parsed-path uri))
+	  (bp base-path (cdr bp))
+	  (p path (cdr p)))
+	((or (null bp) (null p))
+	 ;; If p is nil, that means we have something like
+	 ;; (enough-uri "/foo/bar" "/foo/bar/baz.htm"), so
+	 ;; new-parsed-path will be nil.
+	 (when (null bp)
+	   (setq new-parsed-path (copy-list p))
+	   (when (not (symbolp (car new-parsed-path)))
+	     (push :relative new-parsed-path))))
+      (if* (equal (car bp) (car p))
+	 thenret ;; skip it
+	 else (setq new-parsed-path (copy-list p))
+	      (when (not (symbolp (car new-parsed-path)))
+		(push :relative new-parsed-path))
+	      (return)))
+
+    (let ((new-path 
+	   (when new-parsed-path
+	     (render-parsed-path new-parsed-path
+				 ;; don't know, so have to assume:
+				 t)))
+	  (new-query (uri-query uri))
+	  (new-fragment (uri-fragment uri))
+	  (new-plist (copy-list (uri-plist uri))))
+      (if* (and (null new-scheme)
+		(null new-host)
+		(null new-port)
+		(null new-path)
+		(null new-parsed-path)
+		(null new-query)
+		(null new-fragment))
+	 then ;; can't have a completely empty uri!
+	      (copy-uri nil
+			:class (class-of uri)
+			:place place
+			:path "/"
+			:plist new-plist)
+	 else (copy-uri nil
+			:class (class-of uri)
+			:place place
+			:scheme new-scheme
+			:host new-host
+			:port new-port
+			:path new-path
+			:parsed-path new-parsed-path
+			:query new-query
+			:fragment new-fragment
+			:plist new-plist)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; support for interning URIs
+
+(defun make-uri-space (&rest keys &key (size 777) &allow-other-keys)
+  #+allegro
+  (apply #'make-hash-table :size size
+	 :hash-function 'uri-hash
+	 :test 'uri= :values nil keys)
+  #-allegro
+  (apply #'make-hash-table :size size keys))
+
+(defun gethash-uri (uri table)
+  #+allegro (gethash uri table)
+  #-allegro 
+  (let* ((hash (uri-hash uri))
+	 (existing (gethash hash table)))
+    (dolist (u existing)
+      (when (uri= u uri)
+	(return-from gethash-uri (values u t))))
+    (values nil nil)))
+
+(defun puthash-uri (uri table)
+  #+allegro (excl:puthash-key uri table)
+  #-allegro 
+  (let ((existing (gethash (uri-hash uri) table)))
+    (dolist (u existing)
+      (when (uri= u uri)
+	(return-from puthash-uri u)))
+    (setf (gethash (uri-hash uri) table)
+      (cons uri existing))
+    uri))
+
+
+(defun uri-hash (uri)
+  (if* (uri-hashcode uri)
+     thenret
+     else (setf (uri-hashcode uri)
+		(sxhash
+		 #+allegro
+		 (render-uri uri nil)
+		 #-allegro
+		 (string-downcase 
+		  (render-uri uri nil))))))
+
+(defvar *uris* (make-uri-space))
+
+(defun uri-space () *uris*)
+
+(defun (setf uri-space) (new-val)
+  (setq *uris* new-val))
+
+;; bootstrapping (uri= changed from function to method):
+(when (fboundp 'uri=) (fmakunbound 'uri=))
+
+(defgeneric uri= (uri1 uri2))
+(defmethod uri= ((uri1 uri) (uri2 uri))
+  (when (not (eq (uri-scheme uri1) (uri-scheme uri2)))
+    (return-from uri= nil))
+  ;; RFC2396 says: a URL with an explicit ":port", where the port is
+  ;; the default for the scheme, is the equivalent to one where the
+  ;; port is elided.  Hmmmm.  This means that this function has to be
+  ;; scheme dependent.  Grrrr.
+  (let ((default-port (case (uri-scheme uri1)
+			(:http 80)
+			(:https 443)
+			(:ftp 21)
+			(:telnet 23))))
+    (and (equalp (uri-host uri1) (uri-host uri2))
+	 (eql (or (uri-port uri1) default-port)
+	      (or (uri-port uri2) default-port))
+	 (string= (uri-path uri1) (uri-path uri2))
+	 (string= (uri-query uri1) (uri-query uri2))
+	 (string= (uri-fragment uri1) (uri-fragment uri2)))))
+
+(defmethod uri= ((urn1 urn) (urn2 urn))
+  (when (not (eq (uri-scheme urn1) (uri-scheme urn2)))
+    (return-from uri= nil))
+  (and (equalp (urn-nid urn1) (urn-nid urn2))
+       (urn-nss-equal (urn-nss urn1) (urn-nss urn2))))
+
+(defun urn-nss-equal (nss1 nss2 &aux len)
+  ;; Return t iff the nss values are the same.
+  ;; %2c and %2C are equivalent.
+  (when (or (null nss1) (null nss2)
+	    (not (= (setq len (length nss1))
+		    (length nss2))))
+    (return-from urn-nss-equal nil))
+  (do* ((i 0 (1+ i))
+	(state :char)
+	c1 c2)
+      ((= i len) t)
+    (setq c1 (char nss1 i))
+    (setq c2 (char nss2 i))
+    (ecase state
+      (:char
+       (if* (and (char= #\% c1) (char= #\% c2))
+	  then (setq state :percent+1)
+	elseif (char/= c1 c2)
+	  then (return nil)))
+      (:percent+1
+       (when (char-not-equal c1 c2) (return nil))
+       (setq state :percent+2))
+      (:percent+2
+       (when (char-not-equal c1 c2) (return nil))
+       (setq state :char)))))
+
+(defmethod intern-uri ((xuri uri) &optional (uri-space *uris*))
+  (let ((uri (gethash-uri xuri uri-space)))
+    (if* uri
+       thenret
+       else (puthash-uri xuri uri-space))))
+
+(defmethod intern-uri ((uri string) &optional (uri-space *uris*))
+  (intern-uri (parse-uri uri) uri-space))
+
+(defun unintern-uri (uri &optional (uri-space *uris*))
+  (if* (eq t uri)
+     then (clrhash uri-space)
+   elseif (uri-p uri)
+     then (remhash uri uri-space)
+     else (error "bad uri: ~s." uri)))
+
+(defmacro do-all-uris ((var &optional uri-space result-form)
+		       &rest forms
+		       &environment env)
+  "do-all-uris (var [[uri-space] result-form])
+  		    {declaration}* {tag | statement}*
+Executes the forms once for each uri with var bound to the current uri"
+  (let ((f (gensym))
+	(g-ignore (gensym))
+	(g-uri-space (gensym))
+	(body (third (parse-body forms env))))
+    `(let ((,g-uri-space (or ,uri-space *uris*)))
+       (prog nil
+	 (flet ((,f (,var &optional ,g-ignore)
+		  (declare (ignore-if-unused ,var ,g-ignore))
+		  (tagbody ,@body)))
+	   (maphash #',f ,g-uri-space))
+	 (return ,result-form)))))
+
+(defun sharp-u (stream chr arg)
+  (declare (ignore chr arg))
+  (let ((arg (read stream nil nil t)))
+    (if *read-suppress*
+	nil
+      (if* (stringp arg)
+	 then (parse-uri arg)
+	 else
+
+	 (internal-reader-error
+	  stream
+	  "#u takes a string or list argument: ~s" arg)))))
+
+
+#+allegro
+excl::
+#+allegro
+(locally (declare (special std-lisp-readtable))
+  (let ((*readtable* std-lisp-readtable))
+    (set-dispatch-macro-character #\# #\u #'puri::sharp-u)))
+#-allegro
+(set-dispatch-macro-character #\# #\u #'puri::sharp-u)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide :uri)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; timings
+;; (don't run under emacs with M-x fi:common-lisp)
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (import 'excl::gc))
+
+#-allegro
+(defun gc (&rest options)
+  (declare (ignore options))
+  #+sbcl (sb-ext::gc)
+  #+cmu (ext::gc)
+  )
+
+(defun time-uri-module ()
+  (declare (optimize (speed 3) (safety 0) (debug 0)))
+  (let ((uri "http://www.franz.com/a/b;x;y;z/c/foo?bar=baz&xxx#foo")
+	(uri2 "http://www.franz.com/a/b;x;y;z/c/%2ffoo?bar=baz&xxx#foo"))
+    (gc t) (gc :tenure) (gc :tenure) (gc :tenure)
+    (format t "~&;;; starting timing testing 1...~%")
+    (time (dotimes (i 100000) (parse-uri uri)))
+    
+    (gc t) (gc :tenure) (gc :tenure) (gc :tenure)
+    (format t "~&;;; starting timing testing 2...~%")
+    (let ((uri (parse-uri uri)))
+      (time (dotimes (i 100000)
+	      ;; forces no caching of the printed representation:
+	      (setf (uri-string uri) nil)
+	      (format nil "~a" uri))))
+    
+    (gc t) (gc :tenure) (gc :tenure) (gc :tenure)
+    (format t "~&;;; starting timing testing 3...~%")
+    (time
+     (progn
+       (dotimes (i 100000) (parse-uri uri2))
+       (let ((uri (parse-uri uri)))
+	 (dotimes (i 100000)
+	   ;; forces no caching of the printed representation:
+	   (setf (uri-string uri) nil)
+	   (format nil "~a" uri)))))))
+
+;;******** reference output (ultra, modified 5.0.1):
+;;; starting timing testing 1...
+; cpu time (non-gc) 13,710 msec user, 0 msec system
+; cpu time (gc)     600 msec user, 10 msec system
+; cpu time (total)  14,310 msec user, 10 msec system
+; real time  14,465 msec
+; space allocation:
+;  1,804,261 cons cells, 7 symbols, 41,628,832 other bytes, 0 static bytes
+;;; starting timing testing 2...
+; cpu time (non-gc) 27,500 msec user, 0 msec system
+; cpu time (gc)     280 msec user, 20 msec system
+; cpu time (total)  27,780 msec user, 20 msec system
+; real time  27,897 msec
+; space allocation:
+;  1,900,463 cons cells, 0 symbols, 17,693,712 other bytes, 0 static bytes
+;;; starting timing testing 3...
+; cpu time (non-gc) 52,290 msec user, 10 msec system
+; cpu time (gc)     1,290 msec user, 30 msec system
+; cpu time (total)  53,580 msec user, 40 msec system
+; real time  54,062 msec
+; space allocation:
+;  7,800,205 cons cells, 0 symbols, 81,697,496 other bytes, 0 static bytes
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; after improving decode-escaped-encoding/encode-escaped-encoding:
+
+;;; starting timing testing 1...
+; cpu time (non-gc) 14,520 msec user, 0 msec system
+; cpu time (gc)     400 msec user, 0 msec system
+; cpu time (total)  14,920 msec user, 0 msec system
+; real time  15,082 msec
+; space allocation:
+;  1,800,270 cons cells, 0 symbols, 41,600,160 other bytes, 0 static bytes
+;;; starting timing testing 2...
+; cpu time (non-gc) 27,490 msec user, 10 msec system
+; cpu time (gc)     300 msec user, 0 msec system
+; cpu time (total)  27,790 msec user, 10 msec system
+; real time  28,025 msec
+; space allocation:
+;  1,900,436 cons cells, 0 symbols, 17,693,712 other bytes, 0 static bytes
+;;; starting timing testing 3...
+; cpu time (non-gc) 47,900 msec user, 20 msec system
+; cpu time (gc)     920 msec user, 10 msec system
+; cpu time (total)  48,820 msec user, 30 msec system
+; real time  49,188 msec
+; space allocation:
+;  3,700,215 cons cells, 0 symbols, 81,707,144 other bytes, 0 static bytes

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/tests.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/puri-1.5.1/tests.lisp	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/puri-1.5.1/tests.lisp	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,419 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; copyright (c) 1999-2001 Franz Inc, Berkeley, CA  - All rights reserved.
+;; copyright (c) 2003 Kevin Rosenberg (significant fixes for using
+;; tester package)
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in
+;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
+;;
+;; Original version from ACL 6.1:
+;; t-uri.cl,v 1.3.6.3.2.1 2001/08/09 17:42:43 layer
+;;
+;; $Id: tests.lisp 11031 2006-08-15 00:59:34Z kevin $
+
+
+(defpackage #:puri-tests (:use #:puri #:cl #:ptester))
+(in-package #:puri-tests)
+
+(unintern-uri t)
+
+(defmacro gen-test-forms ()
+  (let ((res '())
+	(base-uri "http://a/b/c/d;p?q"))
+
+    (dolist (x `(;; (relative-uri result base-uri compare-function)
+;;;; RFC Appendix C.1 (normal examples)
+		 ("g:h" "g:h" ,base-uri)
+		 ("g" "http://a/b/c/g" ,base-uri)
+		 ("./g" "http://a/b/c/g" ,base-uri)
+		 ("g/" "http://a/b/c/g/" ,base-uri)
+		 ("/g" "http://a/g" ,base-uri) 
+		 ("//g" "http://g" ,base-uri) 
+                 ;; Following was changed from appendix C of RFC 2396
+                 ;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query
+		 #-ignore ("?y" "http://a/b/c/d;p?y" ,base-uri) 
+		 #+ignore ("?y" "http://a/b/c/?y" ,base-uri) 
+		 ("g?y" "http://a/b/c/g?y" ,base-uri)
+		 ("#s" "http://a/b/c/d;p?q#s" ,base-uri) 
+		 ("g#s" "http://a/b/c/g#s" ,base-uri) 
+		 ("g?y#s" "http://a/b/c/g?y#s" ,base-uri)
+		 (";x" "http://a/b/c/;x" ,base-uri) 
+		 ("g;x" "http://a/b/c/g;x" ,base-uri) 
+		 ("g;x?y#s" "http://a/b/c/g;x?y#s" ,base-uri)
+		 ("." "http://a/b/c/" ,base-uri) 
+		 ("./" "http://a/b/c/" ,base-uri) 
+		 (".." "http://a/b/" ,base-uri) 
+		 ("../" "http://a/b/" ,base-uri)
+		 ("../g" "http://a/b/g" ,base-uri) 
+		 ("../.." "http://a/" ,base-uri) 
+		 ("../../" "http://a/" ,base-uri)
+		 ("../../g" "http://a/g" ,base-uri)
+;;;; RFC Appendix C.2 (abnormal examples)
+		 ("" "http://a/b/c/d;p?q" ,base-uri) 
+		 ("../../../g" "http://a/../g" ,base-uri)
+		 ("../../../../g" "http://a/../../g" ,base-uri) 
+		 ("/./g" "http://a/./g" ,base-uri) 
+		 ("/../g" "http://a/../g" ,base-uri)
+		 ("g." "http://a/b/c/g." ,base-uri) 
+		 (".g" "http://a/b/c/.g" ,base-uri) 
+		 ("g.." "http://a/b/c/g.." ,base-uri)
+		 ("..g" "http://a/b/c/..g" ,base-uri) 
+		 ("./../g" "http://a/b/g" ,base-uri) 
+		 ("./g/." "http://a/b/c/g/" ,base-uri)
+		 ("g/./h" "http://a/b/c/g/h" ,base-uri) 
+		 ("g/../h" "http://a/b/c/h" ,base-uri) 
+		 ("g;x=1/./y" "http://a/b/c/g;x=1/y" ,base-uri)
+		 ("g;x=1/../y" "http://a/b/c/y" ,base-uri) 
+		 ("g?y/./x" "http://a/b/c/g?y/./x" ,base-uri)
+		 ("g?y/../x" "http://a/b/c/g?y/../x" ,base-uri) 
+		 ("g#s/./x" "http://a/b/c/g#s/./x" ,base-uri)
+		 ("g#s/../x" "http://a/b/c/g#s/../x" ,base-uri) 
+		 ("http:g" "http:g" ,base-uri)
+
+		 ("foo/bar/baz.htm#foo"
+		  "http://a/b/foo/bar/baz.htm#foo"
+		  "http://a/b/c.htm")
+		 ("foo/bar/baz.htm#foo"
+		  "http://a/b/foo/bar/baz.htm#foo"
+		  "http://a/b/")
+		 ("foo/bar/baz.htm#foo"
+		  "http://a/foo/bar/baz.htm#foo"
+		  "http://a/b")
+		 ("foo/bar;x;y/bam.htm"
+		  "http://a/b/c/foo/bar;x;y/bam.htm"
+		  "http://a/b/c/")))
+      (push `(test (intern-uri ,(second x))
+			     (intern-uri (merge-uris (intern-uri ,(first x))
+						     (intern-uri ,(third x))))
+			     :test 'uri=)
+	    res))
+
+;;;; intern tests
+    (dolist (x '(;; default port and specifying the default port are
+		 ;; supposed to compare the same:
+		 ("http://www.franz.com:80" "http://www.franz.com")
+		 ("http://www.franz.com:80" "http://www.franz.com" eq)
+		 ;; make sure they're `eq':
+		 ("http://www.franz.com:80" "http://www.franz.com" eq)
+		 ("http://www.franz.com" "http://www.franz.com" eq)
+		 ("http://www.franz.com/foo" "http://www.franz.com/foo" eq)
+		 ("http://www.franz.com/foo?bar"
+		  "http://www.franz.com/foo?bar" eq)
+		 ("http://www.franz.com/foo?bar#baz"
+		  "http://www.franz.com/foo?bar#baz" eq)
+		 ("http://WWW.FRANZ.COM" "http://www.franz.com" eq)
+		 ("http://www.FRANZ.com" "http://www.franz.com" eq)
+		 ("http://www.franz.com" "http://www.franz.com/" eq)
+		 (;; %72 is "r", %2f is "/", %3b is ";"
+		  "http://www.franz.com/ba%72%2f%3b;x;y;z/baz/"
+		  "http://www.franz.com/bar%2f%3b;x;y;z/baz/" eq)))
+      (push `(test (intern-uri ,(second x))
+			     (intern-uri ,(first x))
+	      :test ',(if (third x)
+			  (third x)
+			  'uri=))
+	    res))
+
+;;;; parsing and equivalence tests
+    (push `(test
+	    (parse-uri "http://foo+bar?baz=b%26lob+bof")
+	    (parse-uri (parse-uri "http://foo+bar?baz=b%26lob+bof"))
+	    :test 'uri=)
+	  res)
+    (push '(test
+	    (parse-uri "http://www.foo.com")
+	    (parse-uri (parse-uri "http://www.foo.com?")) ; allow ? at end
+	    :test 'uri=)
+	  res)
+    (push `(test
+	    "baz=b%26lob+bof"
+	    (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof"))
+	    :test 'string=)
+	  res)
+    (push `(test
+	    "baz=b%26lob+bof%3d"
+	    (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof%3d"))
+	    :test 'string=)
+	  res)
+    (push
+     `(test (parse-uri "xxx?%41") (parse-uri "xxx?A") :test 'uri=)
+     res)
+    (push
+     `(test "A" (uri-query (parse-uri "xxx?%41")) :test 'string=)
+     res)
+
+    (push `(test-error (parse-uri " ")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri "foo ")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri " foo ")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri "<foo")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri "foo>")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri "<foo>")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri "%")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri "foo%xyr")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri "\"foo\"")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test "%20" (format nil "~a" (parse-uri "%20"))
+			   :test 'string=)
+	  res)
+    (push `(test "&" (format nil "~a" (parse-uri "%26"))
+			   :test 'string=)
+	  res)
+    (push
+     `(test "foo%23bar" (format nil "~a" (parse-uri "foo%23bar"))
+		      :test 'string=)
+     res)
+    (push
+     `(test "foo%23bar#foobar"
+		      (format nil "~a" (parse-uri "foo%23bar#foobar"))
+		      :test 'string=)
+     res)
+    (push
+     `(test "foo%23bar#foobar#baz"
+		      (format nil "~a" (parse-uri "foo%23bar#foobar#baz"))
+		      :test 'string=)
+     res)
+    (push
+     `(test "foo%23bar#foobar#baz"
+		      (format nil "~a" (parse-uri "foo%23bar#foobar%23baz"))
+		      :test 'string=)
+     res)
+    (push
+     `(test "foo%23bar#foobar/baz"
+		      (format nil "~a" (parse-uri "foo%23bar#foobar%2fbaz"))
+		      :test 'string=)
+     res)
+    (push `(test-error (parse-uri "foobar??")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri "foobar?foo?")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test "foobar?%3f"
+			   (format nil "~a" (parse-uri "foobar?%3f"))
+			   :test 'string=)
+	  res)
+    (push `(test
+	    "http://foo/bAr;3/baz?baf=3"
+	    (format nil "~a" (parse-uri "http://foo/b%41r;3/baz?baf=3"))
+	    :test 'string=)
+	  res)
+    (push `(test
+	    '(:absolute ("/bAr" "3") "baz")
+	    (uri-parsed-path (parse-uri "http://foo/%2fb%41r;3/baz?baf=3"))
+	    :test 'equal)
+	  res)
+    (push `(test
+	    "/%2fbAr;3/baz"
+	    (let ((u (parse-uri "http://foo/%2fb%41r;3/baz?baf=3")))
+	      (setf (uri-parsed-path u) '(:absolute ("/bAr" "3") "baz"))
+	      (uri-path u))
+	    :test 'string=)
+	  res)
+    (push `(test
+	    "http://www.verada.com:8010/kapow?name=foo%3Dbar%25"
+	    (format nil "~a"
+		    (parse-uri
+		     "http://www.verada.com:8010/kapow?name=foo%3Dbar%25"))
+	    :test 'string=)
+	  res)
+    (push `(test
+	    "ftp://parcftp.xerox.com/pub/pcl/mop/"
+	    (format nil "~a"
+		    (parse-uri "ftp://parcftp.xerox.com:/pub/pcl/mop/"))
+	    :test 'string=)
+	  res)
+
+;;;; enough-uri tests
+    (dolist (x `(("http://www.franz.com/foo/bar/baz.htm"
+		  "http://www.franz.com/foo/bar/"
+		  "baz.htm")
+		 ("http://www.franz.com/foo/bar/baz.htm"
+		  "http://www.franz.com/foo/bar"
+		  "baz.htm")
+		 ("http://www.franz.com:80/foo/bar/baz.htm"
+		  "http://www.franz.com:80/foo/bar"
+		  "baz.htm")
+		 ("http:/foo/bar/baz.htm" "http:/foo/bar"  "baz.htm")
+		 ("http:/foo/bar/baz.htm" "http:/foo/bar/" "baz.htm")
+		 ("/foo/bar/baz.htm" "/foo/bar"  "baz.htm")
+		 ("/foo/bar/baz.htm" "/foo/bar/" "baz.htm")
+		 ("/foo/bar/baz.htm#foo" "/foo/bar/" "baz.htm#foo")
+		 ("/foo/bar/baz.htm?bar#foo" "/foo/bar/" "baz.htm?bar#foo")
+		 
+		 ("http://www.dnai.com/~layer/foo.htm"
+		  "http://www.known.net"
+		  "http://www.dnai.com/~layer/foo.htm")
+		 ("http://www.dnai.com/~layer/foo.htm"
+		  "http://www.dnai.com:8000/~layer/"
+		  "http://www.dnai.com/~layer/foo.htm")
+		 ("http://www.dnai.com:8000/~layer/foo.htm"
+		  "http://www.dnai.com/~layer/"
+		  "http://www.dnai.com:8000/~layer/foo.htm")
+		 ("http://www.franz.com"
+		  "http://www.franz.com"
+		  "/")))
+      (push `(test (parse-uri ,(third x))
+			     (enough-uri (parse-uri ,(first x))
+					 (parse-uri ,(second x)))
+			     :test 'uri=)
+	    res))
+    
+;;;; urn tests, ideas of which are from rfc2141
+    (let ((urn "urn:com:foo-the-bar"))
+      (push `(test "com" (urn-nid (parse-uri ,urn))
+			     :test #'string=)
+	    res)
+      (push `(test "foo-the-bar" (urn-nss (parse-uri ,urn))
+			     :test #'string=)
+	    res))
+    (push `(test-error (parse-uri "urn:")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri "urn:foo")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri "urn:foo$")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri "urn:foo_")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test-error (parse-uri "urn:foo:foo&bar")
+				 :condition-type 'uri-parse-error)
+	  res)
+    (push `(test (parse-uri "URN:foo:a123,456")
+			   (parse-uri "urn:foo:a123,456")
+			   :test #'uri=)
+	  res)
+    (push `(test (parse-uri "URN:foo:a123,456")
+			   (parse-uri "urn:FOO:a123,456")
+			   :test #'uri=)
+	  res)
+    (push `(test (parse-uri "urn:foo:a123,456")
+			   (parse-uri "urn:FOO:a123,456")
+			   :test #'uri=)
+	  res)
+    (push `(test (parse-uri "URN:FOO:a123%2c456")
+			   (parse-uri "urn:foo:a123%2C456")
+			   :test #'uri=)
+	  res)
+    (push `(test
+	    nil
+	    (uri= (parse-uri "urn:foo:A123,456")
+		  (parse-uri "urn:FOO:a123,456")))
+	  res)
+    (push `(test
+	    nil
+	    (uri= (parse-uri "urn:foo:A123,456")
+		  (parse-uri "urn:foo:a123,456")))
+	  res)
+    (push `(test
+	    nil
+	    (uri= (parse-uri "urn:foo:A123,456")
+		  (parse-uri "URN:foo:a123,456")))
+	  res)
+    (push `(test
+	    nil
+	    (uri= (parse-uri "urn:foo:a123%2C456")
+		  (parse-uri "urn:FOO:a123,456")))
+	  res)
+    (push `(test
+	    nil
+	    (uri= (parse-uri "urn:foo:a123%2C456")
+		  (parse-uri "urn:foo:a123,456")))
+	  res)
+    (push `(test
+	    nil
+	    (uri= (parse-uri "URN:FOO:a123%2c456")
+		  (parse-uri "urn:foo:a123,456")))
+	  res)
+    (push `(test
+	    nil
+	    (uri= (parse-uri "urn:FOO:a123%2c456")
+		  (parse-uri "urn:foo:a123,456")))
+	  res)
+    (push `(test
+	    nil
+	    (uri= (parse-uri "urn:foo:a123%2c456")
+		  (parse-uri "urn:foo:a123,456")))
+	  res)
+    
+    (push `(test t
+			   (uri= (parse-uri "foo") (parse-uri "foo#")))
+	  res)
+    
+    (push
+     '(let ((puri::*strict-parse* nil))
+       (test-no-error
+	(puri:parse-uri
+	 "http://foo.com/bar?a=zip|zop")))
+     res)
+    (push
+     '(test-error
+       (puri:parse-uri "http://foo.com/bar?a=zip|zop")
+       :condition-type 'uri-parse-error)
+     res)
+    
+    (push
+     '(let ((puri::*strict-parse* nil))
+       (test-no-error
+	(puri:parse-uri
+	 "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041")))
+     res)
+    (push
+     '(test-error
+       (puri:parse-uri
+	"http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041")
+       :condition-type 'uri-parse-error)
+     res)
+    
+    (push
+     '(let ((puri::*strict-parse* nil))
+       (test-no-error
+	(puri:parse-uri
+	 "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843")))
+     res)
+    (push
+     '(test-error
+       (puri:parse-uri
+	"http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843")
+       :condition-type 'uri-parse-error)
+     res)
+    
+    `(progn ,@(nreverse res))))
+
+(defun do-tests ()
+  (let ((*break-on-test-failures* t))
+    (with-tests (:name "puri")
+      (gen-test-forms)))
+  t)
+
+

Added: branches/trunk-reorg/thirdparty/puri-1.5.1/uri.html
===================================================================
--- branches/trunk-reorg/thirdparty/puri-1.5.1/uri.html	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/puri-1.5.1/uri.html	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,406 @@
+<html>
+
+<head>
+<title>URI support in Allegro CL</title>
+</head>
+
+<body>
+
+<h1>URI support in Allegro CL</h1>
+
+<p>This document contains the following sections:</p>
+<p><a href="#uri-intro-1">1.0 Introduction</a><br>
+<a href="#uri-api-1">2.0 The URI API definition</a><br>
+<a href="#parsing-decoding-1">3.0 Parsing, escape decoding/encoding and the path</a><br>
+<a href="#interning-uris-1">4.0 Interning URIs</a><br>
+<a href="#acl-implementation-1">5.0 Allegro CL implementation notes</a><br>
+<a href="#examples-1">6.0 Examples</a><br>
+</p>
+
+<p>This version of the Allegro CL URI support documentation is for distribution with the
+Open Source version of the URI code. Links to Allegro CL documentation other than
+URI-specific files have been supressed. To see Allegro CL documentation, see <a
+href="http://www.franz.com/support/documentation/">http://www.franz.com/support/documentation/</a>,
+which is the Allegro CL documentation page of the franz inc. website. Links to Allegro CL
+documentation can be found on that page. </p>
+
+<hr>
+
+<hr>
+
+<h2><a name="uri-intro-1">1.0 Introduction</a></h2>
+
+<p><em>URI</em> stands for <em>Universal Resource Identifier</em>. For a description of
+URIs, see RFC2396, which can be found in several places, including the IETF web site (<a
+href="http://www.ietf.org/rfc/rfc2396.txt">http://www.ietf.org/rfc/rfc2396.txt</a>) and
+the UCI/ICS web site (<a href="http://www.ics.uci.edu/pub/ietf/uri/rfc2396.txt">http://www.ics.uci.edu/pub/ietf/uri/rfc2396.txt</a>).
+We prefer the UCI/ICS one as it has more examples. </p>
+
+<p>URIs are a superset in functionality and syntax to URLs (Universal Resource Locators)
+and URNs (Universal Resource Names). That is, RFC2396 updates and merges RFC1738 and
+RFC1808 into a single syntax, called the URI. It does exclude some portions of RFC1738
+that define specific syntax of individual URL schemes. </p>
+
+<p>In URL slang, the <em>scheme</em> is usually called the `protocol', but it is called
+scheme in RFC1738. A URL `host' corresponds to the URI `authority.' The URL slang
+`bookmark' or `anchor' is `fragment' in URI lingo. </p>
+
+<p>The URI facility was available as a patch to Allegro CL 5.0.1 and is included with
+release 6.0. the URI facility might not be in an Allegro CL image. Evaluate <code>(require
+:uri)</code> to ensure the facility is loaded (that form returns <code>nil</code> if the
+URI module is already loaded). </p>
+
+<p>Broadly, the URI facility creates a Lisp object that represents a URI, and provides
+setters and accessors to fields in the URI object. The URI object can also be interned,
+much like symbols in CL are. This document describes the facility and the related
+operators. </p>
+
+<p>Aside from the obvious slots which are called out in the RFC, URIs also have a property
+list. With interning, this is another similarity between URIs and CL symbols. </p>
+
+<hr>
+
+<hr>
+
+<h2><a name="uri-api-1">2.0 The URI API definition</a></h2>
+
+<p>Symbols naming objects (functions, variables, etc.) in the <em>uri</em> module are
+exported from the <code>net.uri</code> package. </p>
+
+<p>URIs are represented by CLOS objects. Their slots are: </p>
+
+<pre>
+scheme 
+host 
+port 
+path 
+query
+fragment 
+plist 
+</pre>
+
+<p>The <code>host</code> and <code>port</code> slots together correspond to the <code>authority</code>
+(see RFC2396). There is an accessor-like function, <a href="operators/uri-authority.htm"><b>uri-authority</b></a>,
+that can be used to extract the authority from a URI. See the RFC2396 specifications
+pointed to at the beginning of the <a href="#uri-intro-1">1.0 Introduction</a> for details
+of all the slots except <code>plist</code>. The <code>plist</code> slot contains a
+standard Common Lisp property list. </p>
+
+<p>All symbols are external in the <code>net.uri</code> package, unless otherwise noted.
+Brief descriptions are given in this document, with complete descriptions in the
+individual pages. 
+
+<ul>
+  <li><a href="classes/uri.htm"><code>uri</code></a>: the class of URI objects. </li>
+  <li><a href="classes/urn.htm"><code>urn</code></a>: the class of URN objects. </li>
+  <li><a href="operators/uri-p.htm"><b>uri-p</b></a> <p><b>Arguments: </b><i>object</i></p>
+    <p>Returns true if <i>object</i> is an instance of class <a href="classes/uri.htm"><code>uri</code></a>.
+    </p>
+  </li>
+  <li><a href="operators/copy-uri.htm"><b>copy-uri</b></a> <p><b>Arguments: </b><i>uri </i>&key
+    <i>place scheme host port path query fragment plist </i></p>
+    <p>Copies the specified URI object. See the description page for information on the
+    keyword arguments. </p>
+  </li>
+  <li><a href="operators/uri-scheme.htm"><b>uri-scheme</b></a><br>
+    <a href="operators/uri-host.htm"><b>uri-host</b></a><br>
+    <a href="operators/uri-port.htm"><b>uri-port</b></a><br>
+    <a href="operators/uri-path.htm"><b>uri-path</b></a><br>
+    <a href="operators/uri-query.htm"><b>uri-query</b></a><br>
+    <a href="operators/uri-fragment.htm"><b>uri-fragment</b></a><br>
+    <a href="operators/uri-plist.htm"><b>uri-plist</b></a><br>
+    <p><b>Arguments: </b><i>uri-object </i></p>
+    <p>These accessors return the value of the associated slots of the <i>uri-object</i> </p>
+  </li>
+  <li><a href="operators/uri-authority.htm"><b>uri-authority</b></a> <p><b>Arguments: </b><i>uri-object
+    </i></p>
+    <p>Returns the authority of <i>uri-object</i>. The authority combines the host and port. </p>
+  </li>
+  <li><a href="operators/render-uri.htm"><b>render-uri</b></a> <p><b>Arguments: </b><i>uri
+    stream </i></p>
+    <p>Print to <i>stream</i> the printed representation of <i>uri</i>. </p>
+  </li>
+  <li><a href="operators/parse-uri.htm"><b>parse-uri</b></a> <p><b>Arguments: </b><i>string </i>&key
+    (<i>class</i> 'uri)<i> </i></p>
+    <p>Parse <i>string</i> into a URI object. </p>
+  </li>
+  <li><a href="operators/merge-uris.htm"><b>merge-uris</b></a> <p><b>Arguments: </b><i>uri
+    base-uri </i>&optional <i>place </i></p>
+    <p>Return an absolute URI, based on <i>uri</i>, which can be relative, and <i>base-uri</i>
+    which must be absolute. </p>
+  </li>
+  <li><a href="operators/enough-uri.htm"><b>enough-uri</b></a> <p><b>Arguments: </b><i>uri
+    base </i></p>
+    <p>Converts <i>uri</i> into a relative URI using <i>base</i> as the base URI. </p>
+  </li>
+  <li><a href="operators/uri-parsed-path.htm"><b>uri-parsed-path</b></a> <p><b>Arguments: </b><i>uri
+    </i></p>
+    <p>Return the parsed representation of the path. </p>
+  </li>
+  <li><a href="operators/uri.htm"><b>uri</b></a> <p><b>Arguments: </b><i>object </i></p>
+    <p>Defined methods: if argument is a uri object, return it; create a uri object if
+    possible and return it, or error if not possible. </p>
+  </li>
+</ul>
+
+<hr>
+
+<hr>
+
+<h2><a name="parsing-decoding-1">3.0 Parsing, escape decoding/encoding and the path</a></h2>
+
+<p>The method <a href="operators/uri-path.htm"><b>uri-path</b></a> returns the path
+portion of the URI, in string form. The method <a href="operators/uri-parsed-path.htm"><b>uri-parsed-path</b></a>
+returns the path portion of the URI, in list form. This list form is discussed below,
+after a discussion of decoding/encoding. </p>
+
+<p>RFC2396 lays out a method for inserting into URIs <em>reserved characters</em>. You do
+this by escaping the character. An <em>escaped</em> character is defined like this: </p>
+
+<pre>
+escaped = "%" hex hex 
+
+hex = digit | "A" | "B" | "C" | "D" | "E" | "F" | "a" | "b" | "c" | "d" | "e" | "f" 
+</pre>
+
+<p>In addition, the RFC defines excluded characters: </p>
+
+<pre>
+"<" | ">" | "#" | "%" | <"> | "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" 
+</pre>
+
+<p>The set of reserved characters are: </p>
+
+<pre>
+";" | "/" | "?" | ":" | "@" | "&" | "=" | "+" | "$" | "," 
+</pre>
+
+<p>with the following exceptions: 
+
+<ul>
+  <li>within the authority component, the characters ";", ":",
+    "@", "?", and "/" are reserved. </li>
+  <li>within a path segment, the characters "/", ";", "=", and
+    "?" are reserved. </li>
+  <li>within a query component, the characters ";", "/", "?",
+    ":", "@", "&", "=", "+",
+    ",", and "$" are reserved. </li>
+</ul>
+
+<p>From the RFC, there are two important rules about escaping and unescaping (encoding and
+decoding): 
+
+<ul>
+  <li>decoding should only happen when the URI is parsed into component parts;</li>
+  <li>encoding can only occur when a URI is made from component parts (ie, rendered for
+    printing). </li>
+</ul>
+
+<p>The implication of this is that to decode the URI, it must be in a parsed state. That
+is, you can't convert <font face="Courier New">%2f</font> (the escaped form of
+"/") until the path has been parsed into its component parts. Another important
+desire is for the application viewing the component parts to see the decoded values of the
+components. For example, consider: </p>
+
+<pre>
+http://www.franz.com/calculator/3%2f2 
+</pre>
+
+<p>This might be the implementation of a calculator, and how someone would execute 3/2.
+Clearly, the application that implements this would want to see path components of
+"calculator" and "3/2". "3%2f2" would not be useful to the
+calculator application. </p>
+
+<p>For the reasons given above, a parsed version of the path is available and has the
+following form: </p>
+
+<pre>
+([:absolute | :relative] component1 [component2...]) 
+</pre>
+
+<p>where components are: </p>
+
+<pre>
+element | (element param1 [param2 ...]) 
+</pre>
+
+<p>and <em>element</em> is a path element, and the param's are path element parameters.
+For example, the result of </p>
+
+<pre>
+(uri-parsed-path (parse-uri "foo;10/bar:x;y;z/baz.htm")) 
+</pre>
+
+<p>is </p>
+
+<pre>
+(:relative ("foo" "10") ("bar:x" "y" "z") "baz.htm") 
+</pre>
+
+<p>There is a certain amount of canonicalization that occurs when parsing: 
+
+<ul>
+  <li>A path of <code>(:absolute)</code> or <code>(:absolute "")</code> is
+    equivalent to a <code>nil</code> path. That is, <code>http://a/</code> is parsed with a <code>nil</code>
+    path and printed as <code>http://a</code>. </li>
+  <li>Escaped characters that are not reserved are not escaped upon printing. For example, <code>"foob%61r"</code>
+    is parsed into <code>"foobar"</code> and appears as <code>"foobar"</code>
+    when the URI is printed. </li>
+</ul>
+
+<hr>
+
+<hr>
+
+<h2><a name="interning-uris-1">4.0 Interning URIs</a></h2>
+
+<p>This section describes how to intern URIs. Interning is not mandatory. URIs can be used
+perfectly well without interning them. </p>
+
+<p>Interned URIs in Allegro are like symbols. That is, a string representing a URI, when
+parsed and interned, will always yield an <strong>eq</strong> object. For example: </p>
+
+<pre>
+(eq (intern-uri "http://www.franz.com";) 
+    (intern-uri "http://www.franz.com";)) 
+</pre>
+
+<p>is always true. (Two strings with identical contents may or may not be <strong>eq</strong>
+in Common Lisp, note.) </p>
+
+<p>The functions associated with interning are: 
+
+<ul>
+  <li><a href="operators/make-uri-space.htm"><b>make-uri-space</b></a> <p><b>Arguments: </b>&key
+    <i>size </i></p>
+    <p>Make a new hash-table object to contain interned URIs. </p>
+  </li>
+  <li><a href="operators/uri-space.htm"><b>uri-space</b></a> <p><b>Arguments: </b></p>
+    <p>Return the object into which URIs are currently being interned. </p>
+  </li>
+  <li><a href="operators/uri_eq.htm"><b>uri=</b></a> <p><b>Arguments: </b><i>uri1 uri2 </i></p>
+    <p>Returns true if <i>uri1</i> and <i>uri2</i> are equivalent. </p>
+  </li>
+  <li><a href="operators/intern-uri.htm"><b>intern-uri</b></a> <p><b>Arguments: </b><i>uri-name
+    </i>&optional <i>uri-space </i></p>
+    <p>Intern the uri object specified in the uri-space specified. Methods exist for strings
+    and uri objects. </p>
+  </li>
+  <li><a href="operators/unintern-uri.htm"><b>unintern-uri</b></a> <p><b>Arguments: </b><i>uri
+    </i>&optional <i>uri-space </i></p>
+    <p>Unintern the uri object specified or all uri objects (in <i>uri-space</i> if specified)
+    if <i>uri</i> is <code>t</code>. </p>
+  </li>
+  <li><a href="operators/do-all-uris.htm"><b>do-all-uris</b></a> <p><b>Arguments: </b><i>(var </i>&optional
+    <i>uri-space result) </i>&body <i>body </i></p>
+    <p>Bind <i>var</i> to all currently defined uris (in <i>uri-space</i> if specified) and
+    evaluate <i>body</i>. </p>
+  </li>
+</ul>
+
+<hr>
+
+<hr>
+
+<h2><a name="acl-implementation-1">5.0 Allegro CL implementation notes</a></h2>
+
+<ol>
+  <li>The following are true: <br>
+    <code>(uri= (parse-uri "http://www.franz.com/")</code> <br>
+        <code>(parse-uri "http://www.franz.com"))</code> <br>
+    <code>(eq (intern-uri "http://www.franz.com/")</code> <br>
+       <code>(intern-uri "http://www.franz.com"))</code><br>
+  </li>
+  <li>The following is true: <br>
+    <code>(eq (intern-uri "http://www.franz.com:80/foo/bar.htm")</code> <br>
+        <code>(intern-uri "http://www.franz.com/foo/bar.htm"))</code><br>
+    (I.e. specifying the default port is the same as specifying no port at all. This is
+    specific in RFC2396.) </li>
+  <li>The <em>scheme</em> and <em>authority</em> are case-insensitive. In Allegro CL, the
+    scheme is a keyword that appears in the normal case for the Lisp in which you are
+    executing. </li>
+  <li><code>#u"..."</code> is shorthand for <code>(parse-uri "...")</code>
+    but if an existing <code>#u</code> dispatch macro definition exists, it will not be
+    overridden. </li>
+  <li>The interaction between setting the scheme, host, port, path, query, and fragment slots
+    of URI objects, in conjunction with interning URIs will have very bad and unpredictable
+    results. </li>
+  <li>The printable representation of URIs is cached, for efficiency. This caching is undone
+    when the above slots are changed. That is, when you create a URI the printed
+    representation is cached. When you change one of the above mentioned slots, the printed
+    representation is cleared and calculated when the URI is next printed. For example: </li>
+</ol>
+
+<pre>
+user(10): (setq u #u"http://foo.bar.com/foo/bar";) 
+#<uri http://foo.bar.com/foo/bar>; 
+user(11): (setf (net.uri:uri-host u) "foo.com") 
+"foo.com" 
+user(12): u 
+#<uri http://foo.com/foo/bar>; 
+user(13): 
+</pre>
+
+<p>This allows URIs behavior to follow the principle of least surprise. </p>
+
+<hr>
+
+<hr>
+
+<h2><a name="examples-1">6.0 Examples</a></h2>
+
+<pre>
+uri(10): (use-package :net.uri)
+t
+uri(11): (parse-uri "foo")
+#<uri foo>
+uri(12): #u"foo"
+#<uri foo>
+uri(13): (setq base (intern-uri "http://www.franz.com/foo/bar/";))
+#<uri http://www.franz.com/foo/bar/>;
+uri(14): (merge-uris (parse-uri "foo.htm") base)
+#<uri http://www.franz.com/foo/bar/foo.htm>;
+uri(15): (merge-uris (parse-uri "?foo") base)
+#<uri http://www.franz.com/foo/bar/?foo>;
+uri(16): (setq base (intern-uri "http://www.franz.com/foo/bar/baz.htm";))
+#<uri http://www.franz.com/foo/bar/baz.htm>;
+uri(17): (merge-uris (parse-uri "foo.htm") base)
+#<uri http://www.franz.com/foo/bar/foo.htm>;
+uri(18): (merge-uris #u"?foo" base)
+#<uri http://www.franz.com/foo/bar/?foo>;
+uri(19): (describe #u"http://www.franz.com";)
+#<uri http://www.franz.com>; is an instance of #<standard-class net.uri:uri>:
+ The following slots have :instance allocation:
+  scheme        :http
+  host          "www.franz.com"
+  port          nil
+  path          nil
+  query         nil
+  fragment      nil
+  plist         nil
+  escaped       nil
+  string        "http://www.franz.com";
+  parsed-path   nil
+  hashcode      nil
+uri(20): (describe #u"http://www.franz.com/";)
+#<uri http://www.franz.com>; is an instance of #<standard-class net.uri:uri>:
+ The following slots have :instance allocation:
+  scheme        :http
+  host          "www.franz.com"
+  port          nil
+  path          nil
+  query         nil
+  fragment      nil
+  plist         nil
+  escaped       nil
+  string        "http://www.franz.com";
+  parsed-path   nil
+  hashcode      nil
+uri(21): #u"foobar#baz%23xxx"
+#<uri foobar#baz#xxx>
+</pre>
+
+<p><small>Copyright (c) 1998-2001, Franz Inc. Berkeley, CA., USA. All rights reserved.
+Created 2001.8.16.</small></p>
+</body>
+</html>

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/COPYING
===================================================================
--- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/COPYING	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/COPYING	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,21 @@
+    Copyright (c) 2005 David Lichteblau
+
+    Permission is hereby granted, free of charge, to any person
+    obtaining a copy of this software and associated documentation files
+    (the "Software"), to deal in the Software without restriction,
+    including without limitation the rights to use, copy, modify, merge,
+    publish, distribute, sublicense, and/or sell copies of the Software,
+    and to permit persons to whom the Software is furnished to do so,
+    subject to the following conditions:
+
+    The above copyright notice and this permission notice shall be
+    included in all copies or substantial portions of the Software.
+
+    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+    EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+    MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+    NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+    BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+    ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+    CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+    SOFTWARE.

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Entries
===================================================================
--- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Entries	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Entries	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,7 @@
+/COPYING/1.1/Sun Dec  4 23:41:05 2005//
+/Makefile/1.1.1.1/Wed Nov  9 22:11:00 2005//
+/README/1.3/Thu Sep 14 17:45:36 2006//
+/mixin.lisp/1.5/Thu Sep 14 17:45:36 2006//
+/package.lisp/1.4/Thu Sep 14 17:45:36 2006//
+/trivial-gray-streams.asd/1.1.1.1/Wed Nov  9 22:11:00 2005//
+D

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Repository
===================================================================
--- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Repository	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Repository	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1 @@
+trivial-gray-streams

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Root
===================================================================
--- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Root	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/CVS/Root	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1 @@
+:ext:dlichteblau@common-lisp.net:/project/cl-plus-ssl/cvsroot

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/Makefile
===================================================================
--- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/Makefile	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/Makefile	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,3 @@
+.PHONY: clean
+clean:
+	rm -f *.fasl *.x86f *.fas *.ufsl *.lib *.pfsl

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/README
===================================================================
--- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/README	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/README	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,37 @@
+trivial-gray-streams
+====================
+
+This system provides an extremely thin compatibility layer for gray
+streams.  It is nearly *too* trivial for a complete package, except that
+I have copy&pasted this code into enough projects now that I decided to
+factor it out once again now, and then *never* have to touch it again.
+
+
+How to use it
+=============
+
+1. Use the package TRIVIAL-GRAY-STREAMS instead of whatever
+   implementation-specific package you would have to use otherwise to
+   get at gray stream symbols.
+2. For STREAM-READ-SEQUENCE and STREAM-WRITE-SEQUENCE, notice that we
+   use two required arguments and allow additional keyword arguments.
+   So the lambda list when defining a method on either function should look
+   like this:
+     (stream sequence start end &key)
+3. In order for (2) to work on all Lisps, make sure to subclass all your
+   stream classes from TRIVIAL-GRAY-STREAM-MIXIN if you intend to define
+   methods on those two generic functions.
+
+
+Extensions
+==========
+
+Generic function STREAM-READ-SEQUENCE (stream sequence start end &key)
+Generic function STREAM-WRITE-SEQUENCE (stream sequence start end &key)
+
+	See above.
+
+Generic function STREAM-FILE-POSITION (stream) => file position
+Generic function (SETF STREAM-FILE-POSITION) (position-spec stream) => successp
+
+	Will only be called by LispWorks and CLISP.

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/mixin.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/mixin.lisp	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/mixin.lisp	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,117 @@
+(in-package :trivial-gray-streams)
+
+(defclass trivial-gray-stream-mixin () ())
+
+(defgeneric stream-read-sequence
+    (stream sequence start end &key &allow-other-keys))
+(defgeneric stream-write-sequence
+    (stream sequence start end &key &allow-other-keys))
+
+(defgeneric stream-file-position (stream))
+(defgeneric (setf stream-file-position) (newval stream))
+
+(defmethod stream-write-string
+    ((stream trivial-gray-stream-mixin) seq &optional start end)
+  (stream-write-sequence stream seq (or start 0) (or end (length seq))))
+
+;; Implementations should provide this default method, I believe, but
+;; at least sbcl and allegro don't.
+(defmethod stream-terpri ((stream trivial-gray-stream-mixin))
+  (write-char #\newline stream))
+
+(defmethod stream-file-position ((stream trivial-gray-stream-mixin))
+  nil)
+
+(defmethod (setf stream-file-position)
+    (newval (stream trivial-gray-stream-mixin))
+  (declare (ignore newval))
+  nil)
+
+#+allegro
+(progn
+  (defmethod excl:stream-read-sequence
+      ((s trivial-gray-stream-mixin) seq &optional start end)
+    (stream-read-sequence s seq (or start 0) (or end (length seq))))
+  (defmethod stream:stream-write-sequence
+      ((s trivial-gray-stream-mixin) seq &optional start end)
+    (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+
+#+cmu
+(progn
+  (defmethod ext:stream-read-sequence
+      ((s trivial-gray-stream-mixin) seq &optional start end)
+    (stream-read-sequence s seq (or start 0) (or end (length seq))))
+  (defmethod ext:stream-write-sequence
+      ((s trivial-gray-stream-mixin) seq &optional start end)
+    (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+
+#+lispworks
+(progn
+  (defmethod stream:stream-read-sequence
+      ((s trivial-gray-stream-mixin) seq start end)
+    (stream-read-sequence s seq start end))
+  (defmethod stream:stream-write-sequence
+      ((s trivial-gray-stream-mixin) seq start end)
+    (stream-write-sequence s seq start end))
+
+  (defmethod stream:stream-file-position ((stream trivial-gray-stream-mixin))
+    (stream-file-position stream))
+  (defmethod (setf stream:stream-file-position)
+      (newval (stream trivial-gray-stream-mixin))
+    (setf (stream-file-position stream) newval)))
+
+#+openmcl
+(progn
+  (defmethod ccl:stream-read-vector
+      ((s trivial-gray-stream-mixin) seq start end)
+    (stream-read-sequence s seq start end))
+  (defmethod ccl:stream-write-vector
+      ((s trivial-gray-stream-mixin) seq start end)
+    (stream-write-sequence s seq start end)))
+
+#+clisp
+(progn
+  (defmethod gray:stream-read-byte-sequence
+      ((s trivial-gray-stream-mixin)
+       seq
+       &optional start end no-hang interactive)
+    (when no-hang
+      (error "this stream does not support the NO-HANG argument"))
+    (when interactive
+      (error "this stream does not support the INTERACTIVE argument"))
+    (stream-read-sequence s seq start end))
+
+  (defmethod gray:stream-write-byte-sequence
+      ((s trivial-gray-stream-mixin)
+       seq
+       &optional start end no-hang interactive)
+    (when no-hang
+      (error "this stream does not support the NO-HANG argument"))
+    (when interactive
+      (error "this stream does not support the INTERACTIVE argument"))
+    (stream-write-sequence s seq start end))
+
+  (defmethod gray:stream-read-char-sequence
+      ((s trivial-gray-stream-mixin) seq &optional start end)
+    (stream-read-sequence s seq start end))
+
+  (defmethod gray:stream-write-char-sequence
+      ((s trivial-gray-stream-mixin) seq &optional start end)
+    (stream-write-sequence s seq start end))
+
+  (defmethod gray:stream-position ((stream trivial-gray-stream-mixin) position)
+    (if position
+	(setf (stream-file-position stream) position)
+        (stream-file-position stream))))
+
+#+sbcl
+(progn
+  (defmethod sb-gray:stream-read-sequence
+      ((s trivial-gray-stream-mixin) seq &optional start end)
+    (stream-read-sequence s seq (or start 0) (or end (length seq))))
+  (defmethod sb-gray:stream-write-sequence
+      ((s trivial-gray-stream-mixin) seq &optional start end)
+    (stream-write-sequence s seq (or start 0) (or end (length seq))))
+  ;; SBCL extension:
+  (defmethod sb-gray:stream-line-length ((stream trivial-gray-stream-mixin))
+    80))

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/package.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/package.lisp	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/package.lisp	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,44 @@
+(in-package :trivial-gray-streams-system)
+
+#+cmu
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :gray-streams))
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (fboundp 'stream:stream-write-string)
+    (require "streamc.fasl")))
+
+(macrolet
+    ((frob ()
+       (let
+	   ((common-symbols
+	     '(#:fundamental-stream #:fundamental-input-stream
+	       #:fundamental-output-stream #:fundamental-character-stream
+	       #:fundamental-binary-stream #:fundamental-character-input-stream
+	       #:fundamental-character-output-stream
+	       #:fundamental-binary-input-stream
+	       #:fundamental-binary-output-stream #:stream-read-char
+	       #:stream-unread-char #:stream-read-char-no-hang
+	       #:stream-peek-char #:stream-listen #:stream-read-line
+	       #:stream-clear-input #:stream-write-char #:stream-line-column
+	       #:stream-start-line-p #:stream-write-string #:stream-terpri
+	       #:stream-fresh-line #:stream-finish-output #:stream-force-output
+	       #:stream-clear-output #:stream-advance-to-column
+	       #:stream-read-byte #:stream-write-byte)))
+	 `(defpackage :trivial-gray-streams
+	    (:use :cl)
+	    (:import-from #+sbcl :sb-gray
+			  #+allegro :excl
+			  #+cmu :ext
+			  #+clisp :gray
+			  #+openmcl :ccl
+			  #+lispworks :stream
+			  #-(or sbcl allegro cmu clisp openmcl lispworks) ...
+			  ,@common-symbols)
+	    (:export #:trivial-gray-stream-mixin
+		     #:stream-read-sequence
+		     #:stream-write-sequence
+		     #:stream-file-position
+		     ,@common-symbols)))))
+  (frob))

Added: branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/trivial-gray-streams.asd
===================================================================
--- branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/trivial-gray-streams.asd	2007-10-04 19:10:49 UTC (rev 2204)
+++ branches/trunk-reorg/thirdparty/trivial-gray-streams-2006-09-16/trivial-gray-streams.asd	2007-10-04 19:13:23 UTC (rev 2205)
@@ -0,0 +1,9 @@
+;;; -*- mode: lisp -*-
+
+(defpackage :trivial-gray-streams-system
+(:use :cl :asdf))
+(in-package :trivial-gray-streams-system)
+
+(defsystem :trivial-gray-streams
+  :serial t
+  :components ((:file "package") (:file "mixin")))

    

[bknr-cvs] r2205 - in branches/trunk-reorg/thirdparty: . puri-1.5.1 trivial-gray-streams-2006-09-16 trivial-gray-streams-2006-09-16/CVS

bknr＠bknr.net

tags

participants (1)