bknr-cvs October 2007

bknr-cvs@common-lisp.net

1 participants
67 discussions

[bknr-cvs] r2203 - in branches/trunk-reorg/thirdparty: . cxml-2007-08-05 cxml-2007-08-05/CVS cxml-2007-08-05/contrib cxml-2007-08-05/contrib/CVS cxml-2007-08-05/doc cxml-2007-08-05/doc/CVS cxml-2007-08-05/dom cxml-2007-08-05/dom/CVS cxml-2007-08-05/klacks cxml-2007-08-05/klacks/CVS cxml-2007-08-05/runes cxml-2007-08-05/runes/CVS cxml-2007-08-05/test cxml-2007-08-05/test/CVS cxml-2007-08-05/xml cxml-2007-08-05/xml/CVS cxml-2007-08-05/xml/sax-tests cxml-2007-08-05/xml/sax-tests/CVS
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 15:03:03 -0400 (Thu, 04 Oct 2007) New Revision: 2203 Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/COPYING branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Entries branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Entries.Log branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Repository branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Root branches/trunk-reorg/thirdparty/cxml-2007-08-05/DOMTEST branches/trunk-reorg/thirdparty/cxml-2007-08-05/GNUmakefile branches/trunk-reorg/thirdparty/cxml-2007-08-05/OLDNEWS branches/trunk-reorg/thirdparty/cxml-2007-08-05/README branches/trunk-reorg/thirdparty/cxml-2007-08-05/TIMES branches/trunk-reorg/thirdparty/cxml-2007-08-05/XMLCONF branches/trunk-reorg/thirdparty/cxml-2007-08-05/XMLS-SYMBOLS.diff branches/trunk-reorg/thirdparty/cxml-2007-08-05/catalog.dtd branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/Entries branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/Repository branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/Root branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/xhtmlgen.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/cxml.asd branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/Entries branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/Repository branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/Root branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/GNUmakefile branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/bg.png branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/cxml.css branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/dom.html branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/dom.xml branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/html.xsl branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/index.html branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/index.xml branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/installation.html branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/installation.xml branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/klacks.html branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/klacks.xml branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/quickstart.html branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/quickstart.xml branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/sax.html branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/sax.xml branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/xmls-compat.html branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/xmls-compat.xml branches/trunk-reorg/thirdparty/cxml-2007-08-05/documentation.css branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/Entries branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/Repository branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/Root branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/dom-builder.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/dom-impl.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/dom-sax.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/package.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/Entries branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/Repository branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/Root branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/klacks-impl.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/klacks.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/package.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/tap-source.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/mlisp-patch.diff branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes.asd branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/Entries branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/Repository branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/Root branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/characters.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/definline.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/encodings-data.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/encodings.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/package.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/runes.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/stream-scl.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/syntax.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/utf8.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/xstream.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/ystream.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/Entries branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/Repository branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/Root branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/domtest.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/misc.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/utf8domtest.diff branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/xmlconf-base.diff branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/xmlconf.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Entries branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Entries.Log branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Repository branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Root branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/catalog.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/package.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/recoder.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-handler.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-proxy.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/Entries branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/Repository branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/Root branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/event-collecting-handler.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/package.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/tests.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/space-normalizer.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/split-sequence.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/unparse.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/util.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xml-name-rune-p.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xml-parse.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xmlns-normalizer.lisp branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xmls-compat.lisp Log: update cxml Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/COPYING =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/COPYING 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/COPYING 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,526 @@ +Closure XML -- a Common Lisp XML parser + +Copyright (c) 1999 by Gilbert Baumann +Copyright (c) 2003 by Henrik Motakef +Copyright (c) 2004 knowledgeTools Int. GmbH +Copyright (c) 2004,2005 David Lichteblau + +Preamble to the Gnu Lesser General Public License + +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. + +End of Document +------------------------------------------------------------------------ + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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 + Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Entries 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Entries 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,14 @@ +/COPYING/1.2/Sun Dec 4 23:51:40 2005// +/DOMTEST/1.33/Thu Dec 29 00:37:57 2005// +/GNUmakefile/1.2/Thu Jul 5 20:58:15 2007// +/OLDNEWS/1.1.1.1/Sun Mar 13 18:02:44 2005// +/README/1.1/Sun Feb 18 12:35:49 2007// +/TIMES/1.1.1.1/Sun Mar 13 18:02:46 2005// +/XMLCONF/1.42/Sat Dec 3 21:54:42 2005// +/XMLS-SYMBOLS.diff/1.1.1.1/Sun Mar 13 18:02:48 2005// +/catalog.dtd/1.1.1.1/Sun Mar 13 18:02:52 2005// +/cxml.asd/1.20/Thu Jul 5 20:58:15 2007// +/documentation.css/1.1.1.1/Sun Mar 13 18:02:28 2005// +/mlisp-patch.diff/1.2/Wed Apr 6 19:25:18 2005// +/runes.asd/1.4/Thu Jul 5 20:58:15 2007// +D Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Entries.Log =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Entries.Log 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Entries.Log 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,11 @@ +A D/contrib//// +A D/doc//// +A D/dom//// +A D/glisp//// +A D/klacks//// +A D/pull//// +A D/runes//// +A D/test//// +A D/xml//// +R D/pull//// +R D/glisp//// Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Repository 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Repository 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +cxml Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Root 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/CVS/Root 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +:ext:dlichteblau@common-lisp.net:/project/cxml/cvsroot Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/DOMTEST =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/DOMTEST 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/DOMTEST 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,840 @@ + +#P"/home/david/2001/DOM-Test-Suite/tests/level1/core/" +0/806 attrcreatedocumentfragment.xml +1/806 attrcreatetextnode.xml +2/806 attrcreatetextnode2.xml +3/806 attrdefaultvalue.xml +4/806 attreffectivevalue.xml +5/806 attrentityreplacement.xml +6/806 attrname.xml +7/806 attrnextsiblingnull.xml +8/806 attrnotspecifiedvalue.xml +9/806 attrparentnodenull.xml +10/806 attrprevioussiblingnull.xml +11/806 attrsetvaluenomodificationallowederr.xml +implementationAttribute expandEntityReferences not supported, skipping test +12/806 attrsetvaluenomodificationallowederrEE.xml +13/806 attrspecifiedvalue.xml +14/806 attrspecifiedvaluechanged.xml +15/806 attrspecifiedvalueremove.xml +16/806 cdatasectiongetdata.xml +implementationAttribute coalescing not supported, skipping test +17/806 cdatasectionnormalize.xml +18/806 characterdataappenddata.xml +19/806 characterdataappenddatagetdata.xml +20/806 characterdataappenddatanomodificationallowederr.xml +21/806 characterdataappenddatanomodificationallowederrEE.xml +22/806 characterdatadeletedatabegining.xml +23/806 characterdatadeletedataend.xml +24/806 characterdatadeletedataexceedslength.xml +25/806 characterdatadeletedatagetlengthanddata.xml +26/806 characterdatadeletedatamiddle.xml +27/806 characterdatadeletedatanomodificationallowederrEE.xml +28/806 characterdatagetdata.xml +29/806 characterdatagetlength.xml +30/806 characterdataindexsizeerrdeletedatacountnegative.xml +implementationAttribute signed not supported, skipping test +31/806 characterdataindexsizeerrdeletedataoffsetgreater.xml +32/806 characterdataindexsizeerrdeletedataoffsetnegative.xml +implementationAttribute signed not supported, skipping test +33/806 characterdataindexsizeerrinsertdataoffsetgreater.xml +34/806 characterdataindexsizeerrinsertdataoffsetnegative.xml +implementationAttribute signed not supported, skipping test +35/806 characterdataindexsizeerrreplacedatacountnegative.xml +implementationAttribute signed not supported, skipping test +36/806 characterdataindexsizeerrreplacedataoffsetgreater.xml +37/806 characterdataindexsizeerrreplacedataoffsetnegative.xml +implementationAttribute signed not supported, skipping test +38/806 characterdataindexsizeerrsubstringcountnegative.xml +implementationAttribute signed not supported, skipping test +39/806 characterdataindexsizeerrsubstringnegativeoffset.xml +implementationAttribute signed not supported, skipping test +40/806 characterdataindexsizeerrsubstringoffsetgreater.xml +41/806 characterdatainsertdatabeginning.xml +42/806 characterdatainsertdataend.xml +43/806 characterdatainsertdatamiddle.xml +44/806 characterdatainsertdatanomodificationallowederr.xml +45/806 characterdatainsertdatanomodificationallowederrEE.xml +46/806 characterdatareplacedatabegining.xml +47/806 characterdatareplacedataend.xml +48/806 characterdatareplacedataexceedslengthofarg.xml +49/806 characterdatareplacedataexceedslengthofdata.xml +50/806 characterdatareplacedatamiddle.xml +51/806 characterdatareplacedatanomodificationallowederr.xml +52/806 characterdatareplacedatanomodificationallowederrEE.xml +53/806 characterdatasetdatanomodificationallowederr.xml +54/806 characterdatasetdatanomodificationallowederrEE.xml +55/806 characterdatasetnodevalue.xml +56/806 characterdatasubstringexceedsvalue.xml +57/806 characterdatasubstringvalue.xml +58/806 commentgetcomment.xml +59/806 documentcreateattribute.xml +60/806 documentcreatecdatasection.xml +61/806 documentcreatecomment.xml +62/806 documentcreatedocumentfragment.xml +63/806 documentcreateelement.xml +64/806 documentcreateelementcasesensitive.xml +65/806 documentcreateelementdefaultattr.xml +66/806 documentcreateentityreference.xml +67/806 documentcreateentityreferenceknown.xml +68/806 documentcreateprocessinginstruction.xml +69/806 documentcreatetextnode.xml +70/806 documentgetdoctype.xml +71/806 documentgetdoctypenodtd.xml +72/806 documentgetelementsbytagnamelength.xml +73/806 documentgetelementsbytagnametotallength.xml +74/806 documentgetelementsbytagnamevalue.xml +75/806 documentgetimplementation.xml +76/806 documentgetrootnode.xml +77/806 documentinvalidcharacterexceptioncreateattribute.xml +78/806 documentinvalidcharacterexceptioncreateelement.xml +79/806 documentinvalidcharacterexceptioncreateentref.xml +80/806 documentinvalidcharacterexceptioncreateentref1.xml +81/806 documentinvalidcharacterexceptioncreatepi.xml +82/806 documentinvalidcharacterexceptioncreatepi1.xml +83/806 documenttypegetdoctype.xml +84/806 documenttypegetentities.xml +85/806 documenttypegetentitieslength.xml +86/806 documenttypegetentitiestype.xml +87/806 documenttypegetnotations.xml +88/806 documenttypegetnotationstype.xml +89/806 domimplementationfeaturenoversion.xml +90/806 domimplementationfeaturenull.xml +implementationAttribute hasNullString not supported, skipping test +91/806 domimplementationfeaturexml.xml +92/806 elementaddnewattribute.xml +93/806 elementassociatedattribute.xml +94/806 elementchangeattributevalue.xml +95/806 elementcreatenewattribute.xml +96/806 elementgetattributenode.xml +97/806 elementgetattributenodenull.xml +98/806 elementgetelementempty.xml +99/806 elementgetelementsbytagname.xml +100/806 elementgetelementsbytagnameaccessnodelist.xml +101/806 elementgetelementsbytagnamenomatch.xml +102/806 elementgetelementsbytagnamespecialvalue.xml +103/806 elementgettagname.xml +104/806 elementinuseattributeerr.xml +105/806 elementinvalidcharacterexception.xml +106/806 elementnormalize.xml +107/806 elementnotfounderr.xml +108/806 elementremoveattribute.xml +109/806 elementremoveattributeaftercreate.xml +110/806 elementremoveattributenode.xml +111/806 elementremoveattributenodenomodificationallowederr.xml +112/806 elementremoveattributenodenomodificationallowederrEE.xml +113/806 elementremoveattributenomodificationallowederr.xml +114/806 elementremoveattributenomodificationallowederrEE.xml +115/806 elementremoveattributerestoredefaultvalue.xml +116/806 elementreplaceattributewithself.xml +117/806 elementreplaceexistingattribute.xml +118/806 elementreplaceexistingattributegevalue.xml +119/806 elementretrieveallattributes.xml +120/806 elementretrieveattrvalue.xml +121/806 elementretrievetagname.xml +122/806 elementsetattributenodenomodificationallowederr.xml +123/806 elementsetattributenodenomodificationallowederrEE.xml +implementationAttribute expandEntityReferences not supported, skipping test +124/806 elementsetattributenodenull.xml +125/806 elementsetattributenomodificationallowederr.xml +implementationAttribute expandEntityReferences not supported, skipping test +126/806 elementsetattributenomodificationallowederrEE.xml +127/806 elementwrongdocumenterr.xml +128/806 entitygetentityname.xml +129/806 entitygetpublicid.xml +130/806 entitygetpublicidnull.xml +131/806 namednodemapchildnoderange.xml +132/806 namednodemapgetnameditem.xml +133/806 namednodemapinuseattributeerr.xml +134/806 namednodemapnotfounderr.xml +135/806 namednodemapnumberofnodes.xml +136/806 namednodemapremovenameditem.xml +137/806 namednodemapremovenameditemgetvalue.xml +138/806 namednodemapremovenameditemreturnnodevalue.xml +139/806 namednodemapreturnattrnode.xml +140/806 namednodemapreturnfirstitem.xml +141/806 namednodemapreturnlastitem.xml +142/806 namednodemapreturnnull.xml +143/806 namednodemapsetnameditem.xml +144/806 namednodemapsetnameditemreturnvalue.xml +145/806 namednodemapsetnameditemthatexists.xml +146/806 namednodemapsetnameditemwithnewvalue.xml +147/806 namednodemapwrongdocumenterr.xml +148/806 nodeappendchild.xml +149/806 nodeappendchildchildexists.xml +150/806 nodeappendchilddocfragment.xml +151/806 nodeappendchildgetnodename.xml +152/806 nodeappendchildinvalidnodetype.xml +153/806 nodeappendchildnewchilddiffdocument.xml +154/806 nodeappendchildnodeancestor.xml +155/806 nodeappendchildnomodificationallowederr.xml +156/806 nodeappendchildnomodificationallowederrEE.xml +157/806 nodeattributenodeattribute.xml +158/806 nodeattributenodename.xml +159/806 nodeattributenodetype.xml +160/806 nodeattributenodevalue.xml +161/806 nodecdatasectionnodeattribute.xml +162/806 nodecdatasectionnodename.xml +163/806 nodecdatasectionnodetype.xml +implementationAttribute coalescing not supported, skipping test +164/806 nodecdatasectionnodevalue.xml +implementationAttribute coalescing not supported, skipping test +165/806 nodechildnodes.xml +166/806 nodechildnodesappendchild.xml +167/806 nodechildnodesempty.xml +168/806 nodecloneattributescopied.xml +169/806 nodeclonefalsenocopytext.xml +170/806 nodeclonegetparentnull.xml +171/806 nodeclonenodefalse.xml +172/806 nodeclonenodetrue.xml +173/806 nodeclonetruecopytext.xml +174/806 nodecommentnodeattributes.xml +175/806 nodecommentnodename.xml +176/806 nodecommentnodetype.xml +177/806 nodecommentnodevalue.xml +178/806 nodedocumentfragmentnodename.xml +179/806 nodedocumentfragmentnodetype.xml +180/806 nodedocumentfragmentnodevalue.xml +181/806 nodedocumentnodeattribute.xml +182/806 nodedocumentnodename.xml +183/806 nodedocumentnodetype.xml +184/806 nodedocumentnodevalue.xml +185/806 nodedocumenttypenodename.xml +186/806 nodedocumenttypenodetype.xml +187/806 nodedocumenttypenodevalue.xml +188/806 nodeelementnodeattributes.xml +189/806 nodeelementnodename.xml +190/806 nodeelementnodetype.xml +191/806 nodeelementnodevalue.xml +192/806 nodeentitynodeattributes.xml +193/806 nodeentitynodename.xml +194/806 nodeentitynodetype.xml +195/806 nodeentitynodevalue.xml +196/806 nodeentitysetnodevalue.xml +197/806 nodeentityreferencenodeattributes.xml +198/806 nodeentityreferencenodename.xml +199/806 nodeentityreferencenodetype.xml +200/806 nodeentityreferencenodevalue.xml +201/806 nodegetfirstchild.xml +202/806 nodegetfirstchildnull.xml +203/806 nodegetlastchild.xml +204/806 nodegetlastchildnull.xml +205/806 nodegetnextsibling.xml +206/806 nodegetnextsiblingnull.xml +207/806 nodegetownerdocument.xml +208/806 nodegetownerdocumentnull.xml +209/806 nodegetprevioussibling.xml +210/806 nodegetprevioussiblingnull.xml +211/806 nodehaschildnodes.xml +212/806 nodehaschildnodesfalse.xml +213/806 nodeinsertbefore.xml +214/806 nodeinsertbeforedocfragment.xml +215/806 nodeinsertbeforeinvalidnodetype.xml +216/806 nodeinsertbeforenewchilddiffdocument.xml +217/806 nodeinsertbeforenewchildexists.xml +218/806 nodeinsertbeforenodeancestor.xml +219/806 nodeinsertbeforenodename.xml +220/806 nodeinsertbeforenomodificationallowederr.xml +221/806 nodeinsertbeforenomodificationallowederrEE.xml +222/806 nodeinsertbeforerefchildnonexistent.xml +223/806 nodeinsertbeforerefchildnull.xml +224/806 nodelistindexequalzero.xml +225/806 nodelistindexgetlength.xml +226/806 nodelistindexgetlengthofemptylist.xml +227/806 nodelistindexnotzero.xml +228/806 nodelistreturnfirstitem.xml +229/806 nodelistreturnlastitem.xml +230/806 nodelisttraverselist.xml +231/806 nodenotationnodeattributes.xml +232/806 nodenotationnodename.xml +233/806 nodenotationnodetype.xml +234/806 nodenotationnodevalue.xml +235/806 nodeparentnode.xml +236/806 nodeparentnodenull.xml +237/806 nodeprocessinginstructionnodeattributes.xml +238/806 nodeprocessinginstructionnodename.xml +239/806 nodeprocessinginstructionnodetype.xml +240/806 nodeprocessinginstructionnodevalue.xml +241/806 nodeprocessinginstructionsetnodevalue.xml +242/806 noderemovechild.xml +243/806 noderemovechildgetnodename.xml +244/806 noderemovechildnode.xml +245/806 noderemovechildnomodificationallowederr.xml +246/806 noderemovechildnomodificationallowederrEE.xml +247/806 noderemovechildoldchildnonexistent.xml +248/806 nodereplacechild.xml +249/806 nodereplacechildinvalidnodetype.xml +250/806 nodereplacechildnewchilddiffdocument.xml +251/806 nodereplacechildnewchildexists.xml +252/806 nodereplacechildnodeancestor.xml +253/806 nodereplacechildnodename.xml +254/806 nodereplacechildnomodificationallowederr.xml +255/806 nodereplacechildnomodificationallowederrEE.xml +256/806 nodereplacechildoldchildnonexistent.xml +257/806 nodesetnodevaluenomodificationallowederr.xml +258/806 nodesetnodevaluenomodificationallowederrEE.xml +259/806 nodetextnodeattribute.xml +260/806 nodetextnodename.xml +261/806 nodetextnodetype.xml +262/806 nodetextnodevalue.xml +263/806 notationgetnotationname.xml +264/806 notationgetpublicid.xml +265/806 notationgetpublicidnull.xml +266/806 notationgetsystemid.xml +267/806 notationgetsystemidnull.xml +268/806 processinginstructiongetdata.xml +269/806 processinginstructiongettarget.xml +270/806 processinginstructionsetdatanomodificationallowederr.xml +implementationAttribute expandEntityReferences not supported, skipping test +271/806 processinginstructionsetdatanomodificationallowederrEE.xml +272/806 textindexsizeerrnegativeoffset.xml +implementationAttribute signed not supported, skipping test +273/806 textindexsizeerroffsetoutofbounds.xml +274/806 textparseintolistofelements.xml +275/806 textsplittextfour.xml +276/806 textsplittextnomodificationallowederr.xml +277/806 textsplittextnomodificationallowederrEE.xml +278/806 textsplittextone.xml +279/806 textsplittextthree.xml +280/806 textsplittexttwo.xml +281/806 textwithnomarkup.xml +282/806 nodevalue01.xml +283/806 nodevalue02.xml +284/806 nodevalue03.xml +285/806 nodevalue04.xml +286/806 nodevalue05.xml +287/806 nodevalue06.xml +288/806 nodevalue07.xml +289/806 nodevalue08.xml +290/806 nodevalue09.xml +291/806 hc_attrcreatedocumentfragment.xml +292/806 hc_attrcreatetextnode.xml +293/806 hc_attrcreatetextnode2.xml +294/806 hc_attreffectivevalue.xml +295/806 hc_attrname.xml +296/806 hc_attrnextsiblingnull.xml +297/806 hc_attrparentnodenull.xml +298/806 hc_attrprevioussiblingnull.xml +299/806 hc_attrspecifiedvalue.xml +300/806 hc_attrspecifiedvaluechanged.xml +301/806 hc_characterdataappenddata.xml +302/806 hc_characterdataappenddatagetdata.xml +303/806 hc_characterdatadeletedatabegining.xml +304/806 hc_characterdatadeletedataend.xml +305/806 hc_characterdatadeletedataexceedslength.xml +306/806 hc_characterdatadeletedatagetlengthanddata.xml +307/806 hc_characterdatadeletedatamiddle.xml +308/806 hc_characterdatagetdata.xml +309/806 hc_characterdatagetlength.xml +310/806 hc_characterdataindexsizeerrdeletedatacountnegative.xml +implementationAttribute signed not supported, skipping test +311/806 hc_characterdataindexsizeerrdeletedataoffsetgreater.xml +312/806 hc_characterdataindexsizeerrdeletedataoffsetnegative.xml +implementationAttribute signed not supported, skipping test +313/806 hc_characterdataindexsizeerrinsertdataoffsetgreater.xml +314/806 hc_characterdataindexsizeerrinsertdataoffsetnegative.xml +implementationAttribute signed not supported, skipping test +315/806 hc_characterdataindexsizeerrreplacedatacountnegative.xml +implementationAttribute signed not supported, skipping test +316/806 hc_characterdataindexsizeerrreplacedataoffsetgreater.xml +317/806 hc_characterdataindexsizeerrreplacedataoffsetnegative.xml +implementationAttribute signed not supported, skipping test +318/806 hc_characterdataindexsizeerrsubstringcountnegative.xml +implementationAttribute signed not supported, skipping test +319/806 hc_characterdataindexsizeerrsubstringnegativeoffset.xml +implementationAttribute signed not supported, skipping test +320/806 hc_characterdataindexsizeerrsubstringoffsetgreater.xml +321/806 hc_characterdatainsertdatabeginning.xml +322/806 hc_characterdatainsertdataend.xml +323/806 hc_characterdatainsertdatamiddle.xml +324/806 hc_characterdatareplacedatabegining.xml +325/806 hc_characterdatareplacedataend.xml +326/806 hc_characterdatareplacedataexceedslengthofarg.xml +327/806 hc_characterdatareplacedataexceedslengthofdata.xml +328/806 hc_characterdatareplacedatamiddle.xml +329/806 hc_characterdatasetnodevalue.xml +330/806 hc_characterdatasubstringexceedsvalue.xml +331/806 hc_characterdatasubstringvalue.xml +332/806 hc_commentgetcomment.xml +333/806 hc_documentcreateattribute.xml +334/806 hc_documentcreatecomment.xml +335/806 hc_documentcreatedocumentfragment.xml +336/806 hc_documentcreateelement.xml +337/806 hc_documentcreateelementcasesensitive.xml +338/806 hc_documentcreatetextnode.xml +339/806 hc_documentgetdoctype.xml +340/806 hc_documentgetelementsbytagnamelength.xml +341/806 hc_documentgetelementsbytagnametotallength.xml +342/806 hc_documentgetelementsbytagnamevalue.xml +343/806 hc_documentgetimplementation.xml +344/806 hc_documentgetrootnode.xml +345/806 hc_documentinvalidcharacterexceptioncreateattribute.xml +346/806 hc_documentinvalidcharacterexceptioncreateattribute1.xml +347/806 hc_documentinvalidcharacterexceptioncreateelement.xml +348/806 hc_documentinvalidcharacterexceptioncreateelement1.xml +349/806 hc_domimplementationfeaturenoversion.xml +350/806 hc_domimplementationfeaturenull.xml +implementationAttribute hasNullString not supported, skipping test +351/806 hc_domimplementationfeaturexml.xml +352/806 hc_elementaddnewattribute.xml +353/806 hc_elementassociatedattribute.xml +354/806 hc_elementchangeattributevalue.xml +355/806 hc_elementcreatenewattribute.xml +356/806 hc_elementgetattributenode.xml +357/806 hc_elementgetattributenodenull.xml +358/806 hc_elementgetelementempty.xml +359/806 hc_elementgetelementsbytagname.xml +360/806 hc_elementgetelementsbytagnameaccessnodelist.xml +361/806 hc_elementgetelementsbytagnamenomatch.xml +362/806 hc_elementgetelementsbytagnamespecialvalue.xml +363/806 hc_elementgettagname.xml +364/806 hc_elementinuseattributeerr.xml +365/806 hc_elementinvalidcharacterexception.xml +366/806 hc_elementinvalidcharacterexception1.xml +367/806 hc_elementnormalize.xml +368/806 hc_elementnotfounderr.xml +369/806 hc_elementremoveattribute.xml +370/806 hc_elementremoveattributeaftercreate.xml +371/806 hc_elementremoveattributenode.xml +372/806 hc_elementreplaceattributewithself.xml +373/806 hc_elementreplaceexistingattribute.xml +374/806 hc_elementreplaceexistingattributegevalue.xml +375/806 hc_elementretrieveallattributes.xml +376/806 hc_elementretrieveattrvalue.xml +377/806 hc_elementretrievetagname.xml +378/806 hc_elementsetattributenodenull.xml +379/806 hc_elementwrongdocumenterr.xml +380/806 hc_entitiesremovenameditem1.xml +381/806 hc_entitiessetnameditem1.xml +382/806 hc_namednodemapchildnoderange.xml +383/806 hc_namednodemapgetnameditem.xml +384/806 hc_namednodemapinuseattributeerr.xml +385/806 hc_namednodemapnotfounderr.xml +386/806 hc_namednodemapnumberofnodes.xml +387/806 hc_namednodemapremovenameditem.xml +388/806 hc_namednodemapreturnattrnode.xml +389/806 hc_namednodemapreturnfirstitem.xml +390/806 hc_namednodemapreturnlastitem.xml +391/806 hc_namednodemapreturnnull.xml +392/806 hc_namednodemapsetnameditem.xml +393/806 hc_namednodemapsetnameditemreturnvalue.xml +394/806 hc_namednodemapsetnameditemthatexists.xml +395/806 hc_namednodemapsetnameditemwithnewvalue.xml +396/806 hc_namednodemapwrongdocumenterr.xml +397/806 hc_nodeappendchild.xml +398/806 hc_nodeappendchildchildexists.xml +399/806 hc_nodeappendchilddocfragment.xml +400/806 hc_nodeappendchildgetnodename.xml +401/806 hc_nodeappendchildinvalidnodetype.xml +402/806 hc_nodeappendchildnewchilddiffdocument.xml +403/806 hc_nodeappendchildnodeancestor.xml +404/806 hc_nodeattributenodeattribute.xml +405/806 hc_nodeattributenodename.xml +406/806 hc_nodeattributenodetype.xml +407/806 hc_nodeattributenodevalue.xml +408/806 hc_nodechildnodes.xml +409/806 hc_nodechildnodesappendchild.xml +410/806 hc_nodechildnodesempty.xml +411/806 hc_nodecloneattributescopied.xml +412/806 hc_nodeclonefalsenocopytext.xml +413/806 hc_nodeclonegetparentnull.xml +414/806 hc_nodeclonenodefalse.xml +415/806 hc_nodeclonenodetrue.xml +416/806 hc_nodeclonetruecopytext.xml +417/806 hc_nodecommentnodeattributes.xml +418/806 hc_nodecommentnodename.xml +419/806 hc_nodecommentnodetype.xml +420/806 hc_nodecommentnodevalue.xml +421/806 hc_nodedocumentfragmentnodename.xml +422/806 hc_nodedocumentfragmentnodetype.xml +423/806 hc_nodedocumentfragmentnodevalue.xml +424/806 hc_nodedocumentnodeattribute.xml +425/806 hc_nodedocumentnodename.xml +426/806 hc_nodedocumentnodetype.xml +427/806 hc_nodedocumentnodevalue.xml +428/806 hc_nodeelementnodeattributes.xml +429/806 hc_nodeelementnodename.xml +430/806 hc_nodeelementnodetype.xml +431/806 hc_nodeelementnodevalue.xml +432/806 hc_nodegetfirstchild.xml +433/806 hc_nodegetfirstchildnull.xml +434/806 hc_nodegetlastchild.xml +435/806 hc_nodegetlastchildnull.xml +436/806 hc_nodegetnextsibling.xml +437/806 hc_nodegetnextsiblingnull.xml +438/806 hc_nodegetownerdocument.xml +439/806 hc_nodegetownerdocumentnull.xml +440/806 hc_nodegetprevioussibling.xml +441/806 hc_nodegetprevioussiblingnull.xml +442/806 hc_nodehaschildnodes.xml +443/806 hc_nodehaschildnodesfalse.xml +444/806 hc_nodeinsertbefore.xml +445/806 hc_nodeinsertbeforedocfragment.xml +446/806 hc_nodeinsertbeforeinvalidnodetype.xml +447/806 hc_nodeinsertbeforenewchilddiffdocument.xml +448/806 hc_nodeinsertbeforenewchildexists.xml +449/806 hc_nodeinsertbeforenodeancestor.xml +450/806 hc_nodeinsertbeforenodename.xml +451/806 hc_nodeinsertbeforerefchildnonexistent.xml +452/806 hc_nodeinsertbeforerefchildnull.xml +453/806 hc_nodelistindexequalzero.xml +454/806 hc_nodelistindexgetlength.xml +455/806 hc_nodelistindexgetlengthofemptylist.xml +456/806 hc_nodelistindexnotzero.xml +457/806 hc_nodelistreturnfirstitem.xml +458/806 hc_nodelistreturnlastitem.xml +459/806 hc_nodelisttraverselist.xml +460/806 hc_nodeparentnode.xml +461/806 hc_nodeparentnodenull.xml +462/806 hc_noderemovechild.xml +463/806 hc_noderemovechildgetnodename.xml +464/806 hc_noderemovechildnode.xml +465/806 hc_noderemovechildoldchildnonexistent.xml +466/806 hc_nodereplacechild.xml +467/806 hc_nodereplacechildinvalidnodetype.xml +468/806 hc_nodereplacechildnewchilddiffdocument.xml +469/806 hc_nodereplacechildnodeancestor.xml +470/806 hc_nodereplacechildnodename.xml +471/806 hc_nodereplacechildoldchildnonexistent.xml +472/806 hc_nodetextnodeattribute.xml +473/806 hc_nodetextnodename.xml +474/806 hc_nodetextnodetype.xml +475/806 hc_nodetextnodevalue.xml +476/806 hc_nodevalue01.xml +477/806 hc_nodevalue02.xml +478/806 hc_nodevalue03.xml +479/806 hc_nodevalue04.xml +480/806 hc_nodevalue05.xml +481/806 hc_nodevalue06.xml +482/806 hc_nodevalue07.xml +483/806 hc_nodevalue08.xml +484/806 hc_notationsremovenameditem1.xml +485/806 hc_notationssetnameditem1.xml +486/806 hc_textindexsizeerrnegativeoffset.xml +implementationAttribute signed not supported, skipping test +487/806 hc_textindexsizeerroffsetoutofbounds.xml +488/806 hc_textparseintolistofelements.xml +489/806 hc_textsplittextfour.xml +490/806 hc_textsplittextone.xml +491/806 hc_textsplittextthree.xml +492/806 hc_textsplittexttwo.xml +493/806 hc_textwithnomarkup.xml +494/806 hc_attrappendchild1.xml +495/806 hc_attrappendchild2.xml +496/806 hc_attrappendchild3.xml +497/806 hc_attrappendchild4.xml +498/806 hc_attrappendchild5.xml +499/806 hc_attrappendchild6.xml +500/806 hc_attrchildnodes1.xml +501/806 hc_attrchildnodes2.xml +502/806 hc_attrclonenode1.xml +503/806 hc_attrfirstchild.xml +504/806 hc_attrgetvalue1.xml +505/806 hc_attrgetvalue2.xml +506/806 hc_attrhaschildnodes.xml +507/806 hc_attrinsertbefore1.xml +508/806 hc_attrinsertbefore2.xml +509/806 hc_attrinsertbefore3.xml +510/806 hc_attrinsertbefore4.xml +511/806 hc_attrinsertbefore5.xml +512/806 hc_attrinsertbefore6.xml +513/806 hc_attrinsertbefore7.xml +514/806 hc_attrlastchild.xml +515/806 hc_attrnormalize.xml +516/806 hc_attrremovechild1.xml +517/806 hc_attrremovechild2.xml +518/806 hc_attrreplacechild1.xml +519/806 hc_attrreplacechild2.xml +520/806 hc_attrsetvalue1.xml +521/806 hc_attrsetvalue2.xml +522/806 attrremovechild1.xml +523/806 attrreplacechild1.xml + +#P"/home/david/2001/DOM-Test-Suite/tests/level2/core/" +524/806 attrgetownerelement01.xml +525/806 attrgetownerelement02.xml +526/806 attrgetownerelement03.xml +527/806 attrgetownerelement04.xml +528/806 attrgetownerelement05.xml +529/806 createAttributeNS01.xml +530/806 createAttributeNS02.xml +531/806 createAttributeNS03.xml +532/806 createAttributeNS04.xml +533/806 createAttributeNS05.xml +534/806 createAttributeNS06.xml +535/806 createDocument01.xml +536/806 createDocument02.xml +537/806 createDocument03.xml +538/806 createDocument04.xml +539/806 createDocument05.xml +540/806 createDocument06.xml +541/806 createDocument07.xml +542/806 createDocument08.xml +543/806 createDocumentType01.xml +544/806 createDocumentType02.xml +545/806 createDocumentType03.xml +546/806 createDocumentType04.xml +547/806 createElementNS01.xml +548/806 createElementNS02.xml +549/806 createElementNS03.xml +550/806 createElementNS04.xml +551/806 createElementNS05.xml +552/806 documentcreateattributeNS01.xml +553/806 documentcreateattributeNS02.xml +554/806 documentcreateattributeNS03.xml +555/806 documentcreateattributeNS04.xml +556/806 documentcreateattributeNS05.xml +557/806 documentcreateattributeNS06.xml +558/806 documentcreateattributeNS07.xml +559/806 documentcreateelementNS01.xml +560/806 documentcreateelementNS02.xml +561/806 documentcreateelementNS05.xml +562/806 documentcreateelementNS06.xml +563/806 documentgetelementbyid01.xml +564/806 documentgetelementsbytagnameNS01.xml +565/806 documentgetelementsbytagnameNS02.xml +566/806 documentgetelementsbytagnameNS03.xml +567/806 documentgetelementsbytagnameNS04.xml +568/806 documentgetelementsbytagnameNS05.xml +569/806 documentimportnode01.xml +570/806 documentimportnode02.xml +571/806 documentimportnode03.xml +572/806 documentimportnode04.xml +573/806 documentimportnode05.xml +574/806 documentimportnode06.xml +575/806 documentimportnode07.xml +576/806 documentimportnode08.xml +577/806 documentimportnode09.xml +578/806 documentimportnode10.xml +579/806 documentimportnode11.xml +580/806 documentimportnode12.xml +581/806 documentimportnode13.xml +582/806 documentimportnode14.xml +583/806 documentimportnode15.xml +584/806 documentimportnode17.xml +585/806 documentimportnode18.xml +586/806 documentimportnode19.xml +587/806 documentimportnode20.xml +implementationAttribute expandEntityReferences not supported, skipping test +588/806 documentimportnode21.xml +implementationAttribute expandEntityReferences not supported, skipping test +589/806 documentimportnode22.xml +590/806 documenttypeinternalSubset01.xml +591/806 documenttypepublicid01.xml +592/806 documenttypesystemid01.xml +593/806 domimplementationcreatedocument03.xml +594/806 domimplementationcreatedocument04.xml +595/806 domimplementationcreatedocument05.xml +596/806 domimplementationcreatedocument07.xml +597/806 domimplementationcreatedocumenttype01.xml +598/806 domimplementationcreatedocumenttype02.xml +599/806 domimplementationcreatedocumenttype04.xml +600/806 domimplementationfeaturecore.xml +601/806 domimplementationfeaturexmlversion2.xml +602/806 domimplementationhasfeature01.xml +603/806 domimplementationhasfeature02.xml +604/806 elementgetattributenodens01.xml +605/806 elementgetattributenodens02.xml +606/806 elementgetattributenodens03.xml +607/806 elementgetattributens02.xml +608/806 elementgetelementsbytagnamens02.xml +609/806 elementgetelementsbytagnamens04.xml +610/806 elementgetelementsbytagnamens05.xml +611/806 elementhasattribute01.xml +612/806 elementhasattribute02.xml +613/806 elementhasattribute03.xml +614/806 elementhasattribute04.xml +615/806 elementhasattributens01.xml +616/806 elementhasattributens02.xml +617/806 elementhasattributens03.xml +618/806 elementremoveattributens01.xml +619/806 elementsetattributenodens01.xml +620/806 elementsetattributenodens02.xml +621/806 elementsetattributenodens03.xml +622/806 elementsetattributenodens04.xml +623/806 elementsetattributenodens05.xml +624/806 elementsetattributenodens06.xml +implementationAttribute expandEntityReferences not supported, skipping test +625/806 elementsetattributens01.xml +626/806 elementsetattributens02.xml +627/806 elementsetattributens03.xml +628/806 elementsetattributens04.xml +629/806 elementsetattributens05.xml +630/806 elementsetattributens08.xml +631/806 elementsetattributensurinull.xml +632/806 getAttributeNS01.xml +633/806 getAttributeNS02.xml +634/806 getAttributeNS03.xml +635/806 getAttributeNS04.xml +636/806 getAttributeNS05.xml +637/806 getAttributeNodeNS01.xml +638/806 getAttributeNodeNS02.xml +639/806 getElementById01.xml +640/806 getElementById02.xml +641/806 getElementsByTagNameNS01.xml +642/806 getElementsByTagNameNS02.xml +643/806 getElementsByTagNameNS03.xml +644/806 getElementsByTagNameNS04.xml +645/806 getElementsByTagNameNS05.xml +646/806 getElementsByTagNameNS06.xml +647/806 getElementsByTagNameNS07.xml +648/806 getElementsByTagNameNS08.xml +649/806 getElementsByTagNameNS09.xml +650/806 getElementsByTagNameNS10.xml +651/806 getElementsByTagNameNS11.xml +652/806 getElementsByTagNameNS12.xml +653/806 getElementsByTagNameNS13.xml +654/806 getElementsByTagNameNS14.xml +655/806 getNamedItemNS01.xml +656/806 getNamedItemNS02.xml +657/806 getNamedItemNS03.xml +658/806 getNamedItemNS04.xml +659/806 hasAttribute01.xml +660/806 hasAttribute02.xml +661/806 hasAttribute03.xml +662/806 hasAttribute04.xml +663/806 hasAttributeNS01.xml +664/806 hasAttributeNS02.xml +665/806 hasAttributeNS03.xml +666/806 hasAttributeNS04.xml +667/806 hasAttributeNS05.xml +668/806 hasAttributes01.xml +669/806 hasAttributes02.xml +670/806 hc_entitiesremovenameditemns1.xml +671/806 hc_entitiessetnameditemns1.xml +672/806 hc_namednodemapinvalidtype1.xml +673/806 hc_nodedocumentfragmentnormalize1.xml +674/806 hc_nodedocumentfragmentnormalize2.xml +675/806 hc_notationsremovenameditemns1.xml +676/806 hc_notationssetnameditemns1.xml +677/806 importNode01.xml +678/806 importNode02.xml +679/806 importNode03.xml +680/806 importNode04.xml +681/806 importNode05.xml +682/806 importNode06.xml +683/806 importNode07.xml +684/806 importNode08.xml +685/806 importNode09.xml +686/806 importNode10.xml +687/806 importNode11.xml +688/806 importNode12.xml +689/806 importNode13.xml +690/806 importNode14.xml +691/806 importNode15.xml +692/806 importNode16.xml +693/806 importNode17.xml +694/806 internalSubset01.xml +695/806 isSupported01.xml +696/806 isSupported02.xml +697/806 isSupported04.xml +698/806 isSupported05.xml +699/806 isSupported06.xml +700/806 isSupported07.xml +701/806 isSupported09.xml +702/806 isSupported10.xml +703/806 isSupported11.xml +704/806 isSupported12.xml +705/806 isSupported13.xml +706/806 isSupported14.xml +707/806 localName01.xml +708/806 localName02.xml +709/806 localName03.xml +710/806 localName04.xml +711/806 namednodemapgetnameditemns01.xml +712/806 namednodemapgetnameditemns02.xml +713/806 namednodemapgetnameditemns03.xml +714/806 namednodemapgetnameditemns04.xml +715/806 namednodemapgetnameditemns05.xml +716/806 namednodemapgetnameditemns06.xml +717/806 namednodemapremovenameditemns01.xml +718/806 namednodemapremovenameditemns02.xml +719/806 namednodemapremovenameditemns03.xml +720/806 namednodemapremovenameditemns04.xml +721/806 namednodemapremovenameditemns05.xml +722/806 namednodemapremovenameditemns06.xml +723/806 namednodemapremovenameditemns07.xml +724/806 namednodemapremovenameditemns08.xml +725/806 namednodemapremovenameditemns09.xml +726/806 namednodemapsetnameditemns01.xml +727/806 namednodemapsetnameditemns02.xml +728/806 namednodemapsetnameditemns03.xml +729/806 namednodemapsetnameditemns04.xml +730/806 namednodemapsetnameditemns05.xml +731/806 namednodemapsetnameditemns06.xml +732/806 namednodemapsetnameditemns07.xml +733/806 namednodemapsetnameditemns08.xml +734/806 namednodemapsetnameditemns09.xml +735/806 namednodemapsetnameditemns10.xml +736/806 namednodemapsetnameditemns11.xml +737/806 namespaceURI01.xml +738/806 namespaceURI02.xml +739/806 namespaceURI03.xml +740/806 namespaceURI04.xml +741/806 nodegetlocalname03.xml +742/806 nodegetnamespaceuri03.xml +743/806 nodegetownerdocument01.xml +744/806 nodegetownerdocument02.xml +745/806 nodegetprefix03.xml +746/806 nodehasattributes01.xml +747/806 nodehasattributes02.xml +748/806 nodehasattributes03.xml +749/806 nodehasattributes04.xml +750/806 nodeissupported01.xml +751/806 nodeissupported02.xml +752/806 nodeissupported03.xml +753/806 nodeissupported04.xml +754/806 nodeissupported05.xml +755/806 nodenormalize01.xml +756/806 nodesetprefix01.xml +757/806 nodesetprefix02.xml +758/806 nodesetprefix03.xml +759/806 nodesetprefix04.xml +760/806 nodesetprefix05.xml +761/806 nodesetprefix06.xml +762/806 nodesetprefix07.xml +763/806 nodesetprefix08.xml +764/806 nodesetprefix09.xml +765/806 normalize01.xml +766/806 ownerDocument01.xml +767/806 ownerElement01.xml +768/806 ownerElement02.xml +769/806 prefix01.xml +770/806 prefix02.xml +771/806 prefix03.xml +772/806 prefix04.xml +773/806 prefix05.xml +774/806 prefix06.xml +775/806 prefix07.xml +776/806 prefix08.xml +777/806 prefix09.xml +778/806 prefix10.xml +779/806 prefix11.xml +780/806 publicId01.xml +781/806 removeAttributeNS01.xml +782/806 removeAttributeNS02.xml +783/806 removeNamedItemNS01.xml +784/806 removeNamedItemNS02.xml +785/806 removeNamedItemNS03.xml +786/806 setAttributeNS01.xml +787/806 setAttributeNS02.xml +788/806 setAttributeNS03.xml +789/806 setAttributeNS04.xml +790/806 setAttributeNS05.xml +791/806 setAttributeNS06.xml +792/806 setAttributeNS07.xml +793/806 setAttributeNS09.xml +794/806 setAttributeNS10.xml +795/806 setAttributeNodeNS01.xml +796/806 setAttributeNodeNS02.xml +implementationAttribute expandEntityReferences not supported, skipping test +797/806 setAttributeNodeNS03.xml +798/806 setAttributeNodeNS04.xml +799/806 setAttributeNodeNS05.xml +800/806 setNamedItemNS01.xml +801/806 setNamedItemNS02.xml +802/806 setNamedItemNS03.xml +803/806 setNamedItemNS04.xml +804/806 setNamedItemNS05.xml +805/806 systemId01.xml +0/763 tests failed; 43 tests were skipped \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/GNUmakefile =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/GNUmakefile 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/GNUmakefile 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,7 @@ +all: + @echo no such target + @exit 1 + +.PHONY: clean +clean: + find . $ -name \*.fasl -o -name \*.x86f -o -name \*.lx64fsl $ -print0 | xargs -0 rm -f Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/OLDNEWS =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/OLDNEWS 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/OLDNEWS 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,272 @@ +Changes to Gilbert Baumann's Code +======================================== +(Stand dieser Liste: patch-190) + +base-0 + Import of Closure's src/xml and src/glisp + + +Build system +---------------- +patch-14 + dom-builder.lsp braucht package.lisp +patch-17 + xml-parse braucht dom-impl +patch-18 + xml-parse braucht encodings +patch-19 + xml-parse.lisp needs xml-stream.lisp +patch-157 + DOM in eigenes Verzeichnis und System verschoben +patch-158 + COPYING auch im DOM +patch-160 + tests in eigenes Verzeichnis verschoben +patch-184 + commented out most of dep-clisp for now +patch-185 + CLISP fixes + + +glisp durch runes ersetzt +---------------- +patch-139 patch-140 patch-141 patch-142 patch-143 + unbenutzte Funktionen aus glisp entfernt + GLISP keine COMMON-LISP-Symbole mehr exportieren lassen + glisp defpackage weiter vereinfacht +patch-148 + runes.lisp aufgeteilt in runes.lisp und syntax.lisp +patch-149 + CHARACTER-basierte Runen-Implementation +patch-150 + removed support for oldish gcl +patch-151 + removed dep-gcl-2.lisp +patch-152 + clarified glisp license as LLGPL as per Gilbert Baumann +patch-155 + GLISP in RUNES umbenannt +patch-156 + xstream (und encoding) nach runes verschoben +patch-178 +patch-180 + really fixed rune-char + + +DOM fixes +---------------- +patch-3 + add dom:remove-child, dom:import-node +patch-6 + fixed dom:remove-child +patch-7 + strings->rods in set-attribute, too +patch-21 + dom:item und dom:length fuer NodeList implementiert +patch-22 + s/remove-atttribute/remove-attribute +patch-23 + dom:remove-attribute-node korrigiert +patch-24 + neu: dom:remove-attribute +patch-25 + dom:normalize implementiert +patch-26 + get-elements-by-tag-name fuer Element implementiert +patch-32 + s/data/value/ fuer CHARACTER-DATA +patch-33 + Aufruf von Setter-Methoden +patch-34 + (setf value) nachgetragen +patch-35 + (DOM:NODE-VALUE ATTRIBUTE) korrigiert +patch-36 + writer fuer DOM:DATA +patch-37 + (setf dom:node-value) implementiert +patch-43 + hack: implemented CHILD-NODES for ENTITY-REFERENCE +patch-44 + ENTITY-REFERENCE-Kinder als read-only markieren +patch-45 + DOM-EXCEPTION implementiert +patch-46 + fixed special cases in delete-data and replace-data +patch-47 + delete-data: Arraytyp korrigiert +patch-48 + DOM:INSERT-DATA implementiert +patch-49 + bugfix: replace-data for count != (length arg) +patch-50 + patch-46 nachgebessert: offset == length ist OK +patch-51 + fixed special cases in dom:substring-data +patch-52 + fixed patch-36, my (setf dom:data) implementation was bogus +patch-55 + temporary fix: attributes are created with value "" +patch-58 + START-DTD, END-DTD, DOCUMENT-TYPE initialisation +patch-60 + neu: CLONE-NODE +patch-65, patch-66 + verify attribute name syntax in createAttribute +patch-67 + more NAME syntax checks: CREATE-ELEMENT, SET-ATTRIBUTE +patch-68 + CREATE-ATTRIBUTE: set SPECIFIED to true +patch-69, patch-70 + INUSE_ATTRIBUTE_ERR +patch-71 + hacked my resolve-entity function to return NIL for undefined entities +patch-72 + INVALID_CHARACTER_ERR in create-entity-reference, too +patch-73 + Implement no-op methods on (setf node-value) where required... +patch-74 + fixed get-elements-by-tag-name not to include the argument itself +patch-76, patch-77 + implemented DOM:SPLIT-TEXT +patch-80 + noch unfertig: initialisiere dom:enitities richtig, erzeuge Entity-Knoten +patch-82 + dom:notations fuellen +patch-85 + WRONG_DOCUMENT_ERR auch in set-attribute-node +patch-86 + WRONG_DOCUMENT_ERR nicht nur in set-attribute-node, sondern prinzipiell in set-named-item +patch-91 + :NOT_FOUND_ERR in remove-named-item +patch-94 + can-adopt-p implementiert +patch-95 + ENSURE-VALID-INSERTION-REQUEST korrigiert +patch-96 + normalize korrigiert: cdata-section nicht beruehren +patch-98 + DOCUMENTs have owner NIL +patch-101 + (setf dom:data) fuer PI korrigiert +patch-102 + NOT_FOUND_ERR in REMOVE-CHILD +patch-104 + oops, split-text korrigiert +patch-106 + NOT_FOUND_ERROR in removeAttributeNode sucht das Objekt, nicht seinen Namen +patch-107, patch-113 + Defaultwert fuer fehlende Attribute ist der leere Rod-String, nicht NIL +patch-118 + entity und notation maps sind read-only +patch-119 + dom:item liefert NIL bei ungueltigem index +patch-120, patch-122, patch-124 + NodeList reimplementiert +patch-121 + NAMED-NODE-MAP muss auch auf HIERARCHY_REQUEST_ERR pruefen... +patch-128 + ATTRIBUTE hat jetzt Kinder +patch-129 + auch Attribute normalisieren +patch-130 + (setf dom:value) auf einem Attribut darf ein etwaiges Kinderobjekt nicht wiederverwenden +patch-131 + replace-child fuer document-fragment implementiert +patch-132 + CAN-ADOPT-P fuer Parent ATTRIBUTE und Kind CDATA-SECTION korrigiert +patch-133 + DOCUMENT darf nur jeweils ein ELEMENT- und DOCTYPE-Kind haben +patch-137 + neu: map-node-list, do-node-list. ensure-valid-insertion-request korrigiert +patch-165 + ANSI conformance fix in MOVE +patch-181 + ignore fill-pointers in MOVE + +xml-parse.lisp changes +---------------- +patch-5 + (assert (eql initial-speed 1)) in make-xstream +patch-20 + added a forward declaration for *namespace-bindings* +patch-39 + fix for thread safety in p/document +patch-41 + Warnung ueber (nicht) redefinierte Attribute abschalten koennen +patch-54 + call sax:comment; create comment nodes +patch-89 + public-id und system-id der Entities uebergeben +patch-100 + Die XML Deklaration ist keine Processing Instruction. +patch-146 + SAX-Aufrufe korrigiert fuer DTD ohne ID; Entitydeklaration mit SYSTEM ID +patch-166 + added missing format argument in internal-entity-expansion +patch-172 + fixed rod type in appenddata +patch-174 + reordered definitions to avoid forward references +patch-177 + more SBCL warnings removed +patch-188 + new function parse-octets +(See also: patch-58, patch-80, patch-82) + + +DOM-Builder und SAX-Interface +---------------- +patch-57 + Warnungen beseitigt ("undefined variable") +patch-75 + fixed PARENT slot initialization and added a rant about the current implementation +patch-97 + CDATA sections bauen +patch-136 + normalisierte Elemente bauen + +(See also: patch-58, patch-80, patch-82, patch-86, patch-118, patch-120) + + +unparse +---------------- +patch-2 + export UNPARSE-DOCUMENT +patch-144 + Kommentare verstehen (und nicht ausgeben) +patch-189 + new function UNPARSE-DOCUMENT-TO-OCTETS + + +Misc. +---------------- +patch-9 + print elements with their tag-name +patch-11 + print attributes with name and value + +patch-138 + workaround, need to revert this later + +patch-10 reverted by patch-12 +patch-114 reverted by patch-115 +patch-63 reverted by patch-134 +patch-4 patch-38 patch-87 patch-90 patch-103 reverted by patch-154 +patch-154 STRING-DOM nicht mehr verwenden. File ist aber noch da. + + +domtest.cl +---------------- +patch-27 patch-28 patch-29 patch-30 patch-31 patch-40 patch-42 patch-53 +patch-59 patch-61 patch-62 patch-64 patch-78 patch-79 patch-83 patch-84 +patch-88 patch-92 patch-93 patch-99 patch-105 patch-108 patch-111 +patch-116 patch-117 patch-123 patch-153 patch-182 + DOM tests + + +xmlconf.cl +---------------- +patch-13 patch-15 patch-16 patch-147 patch-186 + Testfunktion fuer XML Conformance Test Suite +(need to merge this with Gilbert's work) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/README =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/README 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/README 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,29 @@ + +Closure XML Parser + + An XML parser written in Common Lisp. + + Closure XML was written by Gilbert Baumann (unk6 at + rz.uni-karlsruhe.de) as part of the Closure web browser. + + Contributions to the parser by + * Henrik Motakef (hmot at henrik-motakef.de) + * David Lichteblau (david(a)lichteblau.com) + + CXML implements a namespace-aware, validating XML 1.0 parser + as well as the DOM Level 2 Core interfaces. Two parser interfaces + are offered, one SAX-like, the other similar to StAX. + + CXML is licensed under Lisp-LGPL. + + Send bug reports to cxml-devel(a)common-lisp.net + (http://common-lisp.net/cgi-bin/mailman/listinfo/cxml-devel) + + +Documentation + + Please refer to http://common-lisp.net/project/cxml/ for details. + + The documentation is also available in the doc/ subdirectory of this + source distribution, run `make' in that directory to build HTML + for the XML sources (requires xsltproc). Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/TIMES =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/TIMES 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/TIMES 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,41 @@ +Time required for parsing a simple document (wc: 99621 298859 3267087). + +;; CXML with NIL builder +;; (cxml:parse-file "~/test.xml" nil) + +; cpu time (non-gc) 12,940 msec user, 20 msec system +; cpu time (gc) 0 msec user, 0 msec system +; cpu time (total) 12,940 msec user, 20 msec system +; real time 12,991 msec +; space allocation: +; 4,184,599 cons cells, 47,682,392 other bytes, 0 static bytes + +;; CXML with xmls-compatible builder +;; (cxml:parse-file "~/test.xml" (cxml-xmls:make-xmls-builder)) + +; cpu time (non-gc) 14,370 msec user, 20 msec system +; cpu time (gc) 0 msec user, 0 msec system +; cpu time (total) 14,370 msec user, 20 msec system +; real time 14,387 msec +; space allocation: +; 8,667,564 cons cells, 47,682,600 other bytes, 0 static bytes + +;; For comparison: xmls.lisp +;; (with-open-file (s "~/test.xml") (xmls:parse s :compress-whitespace nil)) + +; cpu time (non-gc) 27,440 msec user, 50 msec system +; cpu time (gc) 860 msec user, 0 msec system +; cpu time (total) 28,300 msec user, 50 msec system +; real time 28,813 msec +; space allocation: +; 14,821,161 cons cells, 243,886,592 other bytes, 0 static bytes + +;; CXML with DOM builder +;; (cxml:parse-file "~/test.xml" (dom:make-dom-builder)) + +; cpu time (non-gc) 34,900 msec user, 40 msec system +; cpu time (gc) 760 msec user, 0 msec system +; cpu time (total) 35,660 msec user, 40 msec system +; real time 35,822 msec +; space allocation: +; 14,645,503 cons cells, 300,235,640 other bytes, 0 static bytes Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/XMLCONF =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/XMLCONF 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/XMLCONF 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,1834 @@ +xmltest/not-wf/sa/001.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/002.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/003.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/004.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/005.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/006.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/007.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/008.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/009.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/010.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/011.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/012.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/013.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/014.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/015.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/016.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/017.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/018.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/019.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/020.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/021.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/022.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/023.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/024.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/025.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/026.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/027.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/028.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/029.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/030.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/031.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/032.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/033.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/034.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/035.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/036.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/037.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/038.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/039.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/040.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/041.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/042.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/043.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/044.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/045.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/046.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/047.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/048.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/049.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/050.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/051.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/052.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/053.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/054.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/055.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/056.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/057.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/058.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/059.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/060.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/061.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/062.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/063.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/064.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/065.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/066.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/067.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/068.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/069.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/070.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/071.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/072.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/073.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/074.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/075.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/076.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/077.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/078.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/079.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/080.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/081.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/082.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/083.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/084.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/085.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/086.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/087.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/088.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/089.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/090.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/091.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/092.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/093.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/094.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/095.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/096.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/097.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/098.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/099.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/100.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/101.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/102.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/103.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/104.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/105.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/106.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/107.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/108.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/109.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/110.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/111.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/112.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/113.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/114.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/115.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/116.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/117.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/118.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/119.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/120.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/121.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/122.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/123.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/124.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/125.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/126.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/127.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/128.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/129.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/130.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/131.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/132.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/133.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/134.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/135.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/136.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/137.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/138.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/139.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/140.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/141.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/142.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/143.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/144.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/145.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/146.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/147.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/148.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/149.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/150.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/151.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/152.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/153.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/154.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/155.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/156.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/157.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/158.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/159.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/160.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/161.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/162.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/163.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/164.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/165.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/166.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/167.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/168.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/169.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/170.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/171.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/172.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/173.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/174.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/sa/175.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/176.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/177.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/178.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/179.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/180.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/181.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/182.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/183.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/184.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/185.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/sa/186.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/001.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/002.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/003.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/004.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/006.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/007.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/008.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/not-sa/009.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/ext-sa/001.xml [not validating:] not-wf [validating:] invalid +xmltest/not-wf/ext-sa/002.xml [not validating:] not-wf [validating:] not-wf +xmltest/not-wf/ext-sa/003.xml [not validating:] not-wf [validating:] not-wf +xmltest/invalid/002.xml [not validating:] input [validating:] invalid +xmltest/invalid/005.xml [not validating:] input [validating:] invalid +xmltest/invalid/006.xml [not validating:] input [validating:] invalid +xmltest/invalid/not-sa/022.xml [not validating:] input/output [validating:] invalid +xmltest/valid/sa/001.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/002.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/003.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/004.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/005.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/006.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/007.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/008.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/009.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/010.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/011.xml [not validating:] input/output [validating:] input/output +valid/sa/012.xml: test applies to parsers without namespace support, skipping +xmltest/valid/sa/013.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/014.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/015.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/016.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/017.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/018.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/019.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/020.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/021.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/022.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/023.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/024.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/025.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/026.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/027.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/028.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/029.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/030.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/031.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/032.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/033.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/034.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/035.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/036.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/037.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/038.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/039.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/040.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/041.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/042.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/043.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/044.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/045.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/046.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/047.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/048.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/049.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/050.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/051.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/052.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/053.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/054.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/055.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/056.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/057.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/058.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/059.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/060.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/061.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/062.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/063.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/064.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/065.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/066.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/067.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/068.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/069.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/070.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/071.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/072.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/073.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/074.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/075.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/076.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/077.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/078.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/079.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/080.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/081.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/082.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/083.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/084.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/085.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/086.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/087.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/088.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/089.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/090.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/091.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/092.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/093.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/094.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/095.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/096.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/097.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/098.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/099.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/100.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/101.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/102.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/103.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/104.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/105.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/106.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/107.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/108.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/109.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/110.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/111.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/112.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/113.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/114.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/115.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/116.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/117.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/118.xml [not validating:] input/output [validating:] input/output +xmltest/valid/sa/119.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/001.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/002.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/003.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/004.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/005.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/006.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/007.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/008.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/009.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/010.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/011.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/012.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/013.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/014.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/015.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/016.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/017.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/018.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/019.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/020.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/021.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/023.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/024.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/025.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/026.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/027.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/028.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/029.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/030.xml [not validating:] input/output [validating:] input/output +xmltest/valid/not-sa/031.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/001.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/002.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/003.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/004.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/005.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/006.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/007.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/008.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/009.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/011.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/012.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/013.xml [not validating:] input/output [validating:] input/output +xmltest/valid/ext-sa/014.xml [not validating:] input/output [validating:] input/output +japanese/pr-xml-little-endian.xml [not validating:] input [validating:] input +japanese/pr-xml-utf-16.xml [not validating:] input [validating:] input +japanese/pr-xml-utf-8.xml [not validating:] input [validating:] input +japanese/weekly-little-endian.xml [not validating:] input [validating:] input +japanese/weekly-utf-16.xml [not validating:] input [validating:] input +japanese/weekly-utf-8.xml [not validating:] input [validating:] input +sun/valid/pe01.xml [not validating:] input [validating:] input +sun/valid/dtd00.xml [not validating:] input/output [validating:] input/output +sun/valid/dtd01.xml [not validating:] input/output [validating:] input/output +sun/valid/element.xml [not validating:] input/output [validating:] input/output +sun/valid/ext01.xml [not validating:] input/output [validating:] input/output +sun/valid/ext02.xml [not validating:] input/output [validating:] input/output +sun/valid/not-sa01.xml [not validating:] input/output [validating:] input/output +sun/valid/not-sa02.xml [not validating:] input/output [validating:] input/output +sun/valid/not-sa03.xml [not validating:] input/output [validating:] input/output +sun/valid/not-sa04.xml [not validating:] input/output [validating:] input/output +sun/valid/notation01.xml [not validating:] input/output [validating:] input/output +sun/valid/optional.xml [not validating:] input/output [validating:] input/output +sun/valid/required00.xml [not validating:] input/output [validating:] input/output +sun/valid/sa01.xml [not validating:] input/output [validating:] input/output +sun/valid/sa02.xml [not validating:] input/output [validating:] input/output +sun/valid/sa03.xml [not validating:] input/output [validating:] input/output +sun/valid/sa04.xml [not validating:] input/output [validating:] input/output +sun/valid/sa05.xml [not validating:] input/output [validating:] input/output +sun/valid/sgml01.xml [not validating:] input/output [validating:] input/output +sun/valid/v-lang01.xml [not validating:] input/output [validating:] input/output +sun/valid/v-lang02.xml [not validating:] input/output [validating:] input/output +sun/valid/v-lang03.xml [not validating:] input/output [validating:] input/output +sun/valid/v-lang04.xml [not validating:] input/output [validating:] input/output +sun/valid/v-lang05.xml [not validating:] input/output [validating:] input/output +sun/valid/v-lang06.xml [not validating:] input/output [validating:] input/output +sun/valid/pe00.xml [not validating:] input/output [validating:] input/output +sun/valid/pe03.xml [not validating:] input/output [validating:] input/output +sun/valid/pe02.xml [not validating:] input/output [validating:] input/output +sun/invalid/dtd01.xml [not validating:] input [validating:] invalid +sun/invalid/dtd02.xml [not validating:] input [validating:] invalid +sun/invalid/dtd03.xml [not validating:] input [validating:] invalid +sun/invalid/el01.xml [not validating:] input [validating:] invalid +sun/invalid/el02.xml [not validating:] input [validating:] invalid +sun/invalid/el03.xml [not validating:] input [validating:] invalid +sun/invalid/el04.xml [not validating:] input [validating:] invalid +sun/invalid/el05.xml [not validating:] input [validating:] invalid +sun/invalid/el06.xml [not validating:] input [validating:] invalid +sun/invalid/id01.xml [not validating:] input [validating:] invalid +sun/invalid/id02.xml [not validating:] input [validating:] invalid +sun/invalid/id03.xml [not validating:] input [validating:] invalid +sun/invalid/id04.xml [not validating:] input [validating:] invalid +sun/invalid/id05.xml [not validating:] input [validating:] invalid +sun/invalid/id06.xml [not validating:] input [validating:] invalid +sun/invalid/id07.xml [not validating:] input [validating:] invalid +sun/invalid/id08.xml [not validating:] input [validating:] invalid +sun/invalid/id09.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa01.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa02.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa04.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa05.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa06.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa07.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa08.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa09.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa10.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa11.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa12.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa13.xml [not validating:] input [validating:] invalid +sun/invalid/not-sa14.xml [not validating:] input [validating:] invalid +sun/invalid/optional01.xml [not validating:] input [validating:] invalid +sun/invalid/optional02.xml [not validating:] input [validating:] invalid +sun/invalid/optional03.xml [not validating:] input [validating:] invalid +sun/invalid/optional04.xml [not validating:] input [validating:] invalid +sun/invalid/optional05.xml [not validating:] input [validating:] invalid +sun/invalid/optional06.xml [not validating:] input [validating:] invalid +sun/invalid/optional07.xml [not validating:] input [validating:] invalid +sun/invalid/optional08.xml [not validating:] input [validating:] invalid +sun/invalid/optional09.xml [not validating:] input [validating:] invalid +sun/invalid/optional10.xml [not validating:] input [validating:] invalid +sun/invalid/optional11.xml [not validating:] input [validating:] invalid +sun/invalid/optional12.xml [not validating:] input [validating:] invalid +sun/invalid/optional13.xml [not validating:] input [validating:] invalid +sun/invalid/optional14.xml [not validating:] input [validating:] invalid +sun/invalid/optional20.xml [not validating:] input [validating:] invalid +sun/invalid/optional21.xml [not validating:] input [validating:] invalid +sun/invalid/optional22.xml [not validating:] input [validating:] invalid +sun/invalid/optional23.xml [not validating:] input [validating:] invalid +sun/invalid/optional24.xml [not validating:] input [validating:] invalid +sun/invalid/optional25.xml [not validating:] input [validating:] invalid +sun/invalid/required00.xml [not validating:] input [validating:] invalid +sun/invalid/required01.xml [not validating:] input [validating:] invalid +sun/invalid/required02.xml [not validating:] input [validating:] invalid +sun/invalid/root.xml [not validating:] input [validating:] invalid +sun/invalid/attr01.xml [not validating:] input [validating:] invalid +sun/invalid/attr02.xml [not validating:] input [validating:] invalid +sun/invalid/attr03.xml [not validating:] input [validating:] invalid +sun/invalid/attr04.xml [not validating:] input [validating:] invalid +sun/invalid/attr05.xml [not validating:] input [validating:] invalid +sun/invalid/attr06.xml [not validating:] input [validating:] invalid +sun/invalid/attr07.xml [not validating:] input [validating:] invalid +sun/invalid/attr08.xml [not validating:] input [validating:] invalid +sun/invalid/attr09.xml [not validating:] input [validating:] invalid +sun/invalid/attr10.xml [not validating:] input [validating:] invalid +sun/invalid/attr11.xml [not validating:] input [validating:] invalid +sun/invalid/attr12.xml [not validating:] input [validating:] invalid +sun/invalid/attr13.xml [not validating:] input [validating:] invalid +sun/invalid/attr14.xml [not validating:] input [validating:] invalid +sun/invalid/attr15.xml [not validating:] input [validating:] invalid +sun/invalid/attr16.xml [not validating:] input [validating:] invalid +sun/invalid/utf16b.xml [not validating:] input [validating:] invalid +sun/invalid/utf16l.xml [not validating:] input [validating:] invalid +sun/invalid/empty.xml [not validating:] input [validating:] invalid +sun/not-wf/not-sa03.xml [not validating:] not-wf [validating:] invalid +sun/not-wf/attlist01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist04.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist05.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist06.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist07.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist08.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist09.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist10.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/attlist11.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/cond01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/cond02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/content01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/content02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/content03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/decl01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd00.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd04.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd05.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/dtd07.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/element00.xml [not validating:] not-wf [validating:] invalid +sun/not-wf/element01.xml [not validating:] not-wf [validating:] invalid +sun/not-wf/element02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/element03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/element04.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding04.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding05.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding06.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/encoding07.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/pi.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/pubid01.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/pubid02.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/pubid03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/pubid04.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/pubid05.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml01.xml [not validating:] not-wf [validating:] invalid +sun/not-wf/sgml02.xml [not validating:] not-wf [validating:] invalid +sun/not-wf/sgml03.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml04.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml05.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml06.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml07.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml08.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml09.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml10.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml11.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml12.xml [not validating:] not-wf [validating:] not-wf +sun/not-wf/sgml13.xml [not validating:] not-wf [validating:] not-wf +oasis/p01pass2.xml [not validating:] input [validating:] input +oasis/p06pass1.xml [not validating:] input [validating:] input +oasis/p07pass1.xml [not validating:] input [validating:] input +p08pass1.xml: test applies to parsers without namespace support, skipping +oasis/p09pass1.xml [not validating:] input [validating:] input +oasis/p12pass1.xml [not validating:] input [validating:] input +oasis/p22pass4.xml [not validating:] input [validating:] input +oasis/p22pass5.xml [not validating:] input [validating:] input +oasis/p22pass6.xml [not validating:] input [validating:] input +oasis/p28pass1.xml [not validating:] input [validating:] input +oasis/p28pass3.xml [not validating:] input [validating:] input +oasis/p28pass4.xml [not validating:] input [validating:] input +oasis/p28pass5.xml [not validating:] input [validating:] input +oasis/p29pass1.xml [not validating:] input [validating:] input +oasis/p30pass1.xml [not validating:] input [validating:] input +oasis/p30pass2.xml [not validating:] input [validating:] input +oasis/p31pass1.xml [not validating:] input [validating:] input +oasis/p31pass2.xml [not validating:] input [validating:] input +oasis/p43pass1.xml [not validating:] input [validating:] input +oasis/p45pass1.xml [not validating:] input [validating:] input +oasis/p46pass1.xml [not validating:] input [validating:] input +oasis/p47pass1.xml [not validating:] input [validating:] input +oasis/p48pass1.xml [not validating:] input [validating:] input +oasis/p49pass1.xml [not validating:] input [validating:] input +oasis/p50pass1.xml [not validating:] input [validating:] input +oasis/p51pass1.xml [not validating:] input [validating:] input +oasis/p52pass1.xml [not validating:] input [validating:] input +oasis/p53pass1.xml [not validating:] input [validating:] input +oasis/p54pass1.xml [not validating:] input [validating:] input +oasis/p55pass1.xml [not validating:] input [validating:] input +oasis/p56pass1.xml [not validating:] input [validating:] input +oasis/p57pass1.xml [not validating:] input [validating:] input +oasis/p58pass1.xml [not validating:] input [validating:] input +oasis/p59pass1.xml [not validating:] input [validating:] input +oasis/p60pass1.xml [not validating:] input [validating:] input +oasis/p61pass1.xml [not validating:] input [validating:] input +oasis/p62pass1.xml [not validating:] input [validating:] input +oasis/p63pass1.xml [not validating:] input [validating:] input +oasis/p64pass1.xml [not validating:] input [validating:] input +oasis/p68pass1.xml [not validating:] input [validating:] input +oasis/p69pass1.xml [not validating:] input [validating:] input +oasis/p70pass1.xml [not validating:] input [validating:] input +oasis/p71pass1.xml [not validating:] input [validating:] input +oasis/p72pass1.xml [not validating:] input [validating:] input +oasis/p73pass1.xml [not validating:] input [validating:] input +oasis/p76pass1.xml [not validating:] input [validating:] input +oasis/p01pass1.xml [not validating:] input [validating:] invalid +oasis/p01pass3.xml [not validating:] input [validating:] invalid +oasis/p03pass1.xml [not validating:] input [validating:] invalid +p04pass1.xml: test applies to parsers without namespace support, skipping +p05pass1.xml: test applies to parsers without namespace support, skipping +oasis/p06fail1.xml [not validating:] input [validating:] invalid +oasis/p08fail1.xml [not validating:] input [validating:] invalid +oasis/p08fail2.xml [not validating:] input [validating:] invalid +oasis/p10pass1.xml [not validating:] input [validating:] invalid +oasis/p14pass1.xml [not validating:] input [validating:] invalid +oasis/p15pass1.xml [not validating:] input [validating:] invalid +oasis/p16pass1.xml [not validating:] input [validating:] invalid +oasis/p16pass2.xml [not validating:] input [validating:] invalid +oasis/p16pass3.xml [not validating:] input [validating:] invalid +oasis/p18pass1.xml [not validating:] input [validating:] invalid +oasis/p22pass1.xml [not validating:] input [validating:] invalid +oasis/p22pass2.xml [not validating:] input [validating:] invalid +oasis/p22pass3.xml [not validating:] input [validating:] invalid +oasis/p23pass1.xml [not validating:] input [validating:] invalid +oasis/p23pass2.xml [not validating:] input [validating:] invalid +oasis/p23pass3.xml [not validating:] input [validating:] invalid +oasis/p23pass4.xml [not validating:] input [validating:] invalid +oasis/p24pass1.xml [not validating:] input [validating:] invalid +oasis/p24pass2.xml [not validating:] input [validating:] invalid +oasis/p24pass3.xml [not validating:] input [validating:] invalid +oasis/p24pass4.xml [not validating:] input [validating:] invalid +oasis/p25pass1.xml [not validating:] input [validating:] invalid +oasis/p25pass2.xml [not validating:] input [validating:] invalid +oasis/p26pass1.xml [not validating:] input [validating:] invalid +oasis/p27pass1.xml [not validating:] input [validating:] invalid +oasis/p27pass2.xml [not validating:] input [validating:] invalid +oasis/p27pass3.xml [not validating:] input [validating:] invalid +oasis/p27pass4.xml [not validating:] input [validating:] invalid +oasis/p32pass1.xml [not validating:] input [validating:] invalid +oasis/p32pass2.xml [not validating:] input [validating:] invalid +oasis/p39pass1.xml [not validating:] input [validating:] invalid +oasis/p39pass2.xml [not validating:] input [validating:] invalid +oasis/p40pass1.xml [not validating:] input [validating:] invalid +oasis/p40pass2.xml [not validating:] input [validating:] invalid +oasis/p40pass3.xml [not validating:] input [validating:] invalid +oasis/p40pass4.xml [not validating:] input [validating:] invalid +oasis/p41pass1.xml [not validating:] input [validating:] invalid +oasis/p41pass2.xml [not validating:] input [validating:] invalid +oasis/p42pass1.xml [not validating:] input [validating:] invalid +oasis/p42pass2.xml [not validating:] input [validating:] invalid +oasis/p44pass1.xml [not validating:] input [validating:] invalid +oasis/p44pass2.xml [not validating:] input [validating:] invalid +oasis/p44pass3.xml [not validating:] input [validating:] invalid +oasis/p44pass4.xml [not validating:] input [validating:] invalid +oasis/p44pass5.xml [not validating:] input [validating:] invalid +oasis/p66pass1.xml [not validating:] input [validating:] invalid +oasis/p74pass1.xml [not validating:] input [validating:] invalid +oasis/p75pass1.xml [not validating:] input [validating:] invalid +oasis/e2.xml [not validating:] input [validating:] invalid +oasis/p01fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p01fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p01fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p01fail4.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail10.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail11.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail12.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail13.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail14.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail15.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail16.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail17.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail18.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail19.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail20.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail21.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail22.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail23.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail24.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail25.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail26.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail27.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail28.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail29.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail30.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail31.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail4.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail5.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail6.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail7.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail8.xml [not validating:] not-wf [validating:] invalid +oasis/p02fail9.xml [not validating:] not-wf [validating:] invalid +oasis/p03fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail10.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail11.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail12.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail13.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail14.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail15.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail16.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail17.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail18.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail19.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail20.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail21.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail22.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail23.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail24.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail25.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail26.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail27.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail28.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail29.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail7.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail8.xml [not validating:] not-wf [validating:] not-wf +oasis/p03fail9.xml [not validating:] not-wf [validating:] not-wf +oasis/p04fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p04fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p04fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p05fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p05fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p05fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p05fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p05fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p09fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p09fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p09fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p09fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p09fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p10fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p10fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p10fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p11fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p11fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail6.xml [not validating:] not-wf [validating:] not-wf +oasis/p12fail7.xml [not validating:] not-wf [validating:] not-wf +oasis/p14fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p14fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p14fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p15fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p15fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p15fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p16fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p16fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p16fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p18fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p18fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p18fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p22fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p22fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p23fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p23fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p23fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p23fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p23fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p24fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p24fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p25fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p26fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p26fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p27fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p28fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p29fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p30fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p31fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p32fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p32fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p32fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p32fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p32fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p39fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p39fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p39fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p39fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p39fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p40fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p40fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p40fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p40fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p41fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p41fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p41fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p42fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p42fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p42fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p43fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p43fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p43fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p44fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p44fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p44fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p44fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p44fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p45fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p45fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p45fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p45fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p46fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p46fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p46fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p46fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p46fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p46fail6.xml [not validating:] not-wf [validating:] not-wf +oasis/p47fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p47fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p47fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p47fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p48fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p48fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p49fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p50fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail6.xml [not validating:] not-wf [validating:] not-wf +oasis/p51fail7.xml [not validating:] not-wf [validating:] not-wf +oasis/p52fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p52fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p53fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p53fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p53fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p53fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p53fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p54fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p55fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p56fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p56fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p56fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p56fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p56fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p57fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p58fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail6.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail7.xml [not validating:] not-wf [validating:] not-wf +oasis/p58fail8.xml [not validating:] not-wf [validating:] not-wf +oasis/p59fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p59fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p59fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p60fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p60fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p60fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p60fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p60fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p61fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p62fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p62fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p63fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p63fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p64fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p64fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p66fail1.xml [not validating:] not-wf [validating:] invalid +oasis/p66fail2.xml [not validating:] not-wf [validating:] invalid +oasis/p66fail3.xml [not validating:] not-wf [validating:] invalid +oasis/p66fail4.xml [not validating:] not-wf [validating:] invalid +oasis/p66fail5.xml [not validating:] not-wf [validating:] invalid +oasis/p66fail6.xml [not validating:] not-wf [validating:] invalid +oasis/p68fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p68fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p68fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p69fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p69fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p69fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p70fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p71fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p71fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p71fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p71fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p72fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p72fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p72fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p72fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p73fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p73fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p73fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p73fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p73fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p74fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p74fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p74fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p75fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p75fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p75fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p75fail4.xml [not validating:] not-wf [validating:] not-wf +oasis/p75fail5.xml [not validating:] not-wf [validating:] not-wf +oasis/p75fail6.xml [not validating:] not-wf [validating:] not-wf +oasis/p76fail1.xml [not validating:] not-wf [validating:] not-wf +oasis/p76fail2.xml [not validating:] not-wf [validating:] not-wf +oasis/p76fail3.xml [not validating:] not-wf [validating:] not-wf +oasis/p76fail4.xml [not validating:] not-wf [validating:] not-wf +ibm/invalid/P28/ibm28i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P32/ibm32i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P32/ibm32i03.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P32/ibm32i04.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P39/ibm39i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P39/ibm39i02.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P39/ibm39i03.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P39/ibm39i04.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P41/ibm41i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P41/ibm41i02.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P45/ibm45i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P49/ibm49i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P50/ibm50i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P51/ibm51i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P51/ibm51i03.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i02.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i03.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i05.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i06.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i07.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i08.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i09.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i10.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i11.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i12.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i13.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i14.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i15.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i16.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i17.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P56/ibm56i18.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P58/ibm58i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P58/ibm58i02.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P59/ibm59i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P60/ibm60i01.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P60/ibm60i02.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P60/ibm60i03.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P60/ibm60i04.xml [not validating:] input/output [validating:] invalid +ibm/invalid/P76/ibm76i01.xml [not validating:] input/output [validating:] invalid +ibm/not-wf/P01/ibm01n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P01/ibm01n02.xml [not validating:] not-wf [validating:] invalid +ibm/not-wf/P01/ibm01n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n15.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n16.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n17.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n18.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n19.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n20.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n21.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n22.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n23.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n24.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n25.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n26.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n27.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n28.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n29.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n30.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n31.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n32.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P02/ibm02n33.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P03/ibm03n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n15.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n16.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n17.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P04/ibm04n18.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P05/ibm05n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P05/ibm05n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P05/ibm05n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P09/ibm09n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P09/ibm09n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P09/ibm09n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P09/ibm09n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P10/ibm10n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P11/ibm11n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P11/ibm11n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P11/ibm11n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P11/ibm11n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P12/ibm12n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P12/ibm12n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P12/ibm12n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P13/ibm13n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P13/ibm13n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P13/ibm13n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P14/ibm14n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P14/ibm14n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P14/ibm14n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P15/ibm15n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P15/ibm15n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P15/ibm15n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P15/ibm15n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P16/ibm16n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P16/ibm16n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P16/ibm16n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P16/ibm16n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P17/ibm17n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P17/ibm17n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P17/ibm17n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P17/ibm17n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P18/ibm18n01.xml [not validating:] not-wf [validating:] invalid +ibm/not-wf/P18/ibm18n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P19/ibm19n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P19/ibm19n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P19/ibm19n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P20/ibm20n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P21/ibm21n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P21/ibm21n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P21/ibm21n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P22/ibm22n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P22/ibm22n02.xml [not validating:] not-wf [validating:] invalid +ibm/not-wf/P22/ibm22n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P23/ibm23n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P23/ibm23n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P23/ibm23n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P23/ibm23n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P23/ibm23n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P23/ibm23n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P24/ibm24n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P25/ibm25n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P25/ibm25n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P26/ibm26n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P27/ibm27n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P28/ibm28n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/p28a/ibm28an01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P29/ibm29n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P30/ibm30n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P31/ibm31n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P32/ibm32n09.xml [not validating:] not-wf [validating:] invalid +ibm/not-wf/P39/ibm39n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P39/ibm39n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P39/ibm39n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P39/ibm39n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P39/ibm39n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P39/ibm39n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P40/ibm40n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P40/ibm40n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P40/ibm40n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P40/ibm40n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P40/ibm40n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P41/ibm41n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P42/ibm42n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P42/ibm42n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P42/ibm42n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P42/ibm42n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P42/ibm42n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P43/ibm43n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P43/ibm43n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P43/ibm43n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P43/ibm43n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P44/ibm44n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P44/ibm44n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P44/ibm44n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P44/ibm44n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P45/ibm45n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P46/ibm46n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P46/ibm46n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P46/ibm46n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P46/ibm46n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P46/ibm46n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P47/ibm47n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P47/ibm47n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P47/ibm47n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P47/ibm47n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P47/ibm47n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P47/ibm47n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P48/ibm48n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P49/ibm49n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P49/ibm49n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P49/ibm49n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P49/ibm49n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P49/ibm49n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P49/ibm49n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P50/ibm50n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P51/ibm51n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P52/ibm52n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P52/ibm52n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P52/ibm52n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P52/ibm52n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P52/ibm52n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P52/ibm52n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P53/ibm53n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P54/ibm54n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P54/ibm54n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P55/ibm55n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P55/ibm55n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P55/ibm55n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P56/ibm56n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P57/ibm57n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P58/ibm58n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P59/ibm59n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P59/ibm59n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P59/ibm59n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P59/ibm59n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P59/ibm59n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P59/ibm59n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P60/ibm60n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P61/ibm61n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P62/ibm62n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P63/ibm63n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P64/ibm64n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P64/ibm64n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P64/ibm64n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P65/ibm65n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P65/ibm65n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P66/ibm66n15.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n06.xml [not validating:] not-wf [validating:] invalid +ibm/not-wf/P68/ibm68n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P68/ibm68n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P69/ibm69n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P69/ibm69n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P69/ibm69n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P69/ibm69n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P69/ibm69n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P69/ibm69n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm70n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P71/ibm71n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P72/ibm72n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P73/ibm73n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P73/ibm73n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P74/ibm74n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P75/ibm75n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P76/ibm76n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P77/ibm77n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P77/ibm77n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P77/ibm77n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P77/ibm77n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P78/ibm78n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P78/ibm78n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P79/ibm79n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P79/ibm79n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P80/ibm80n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P80/ibm80n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P80/ibm80n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P80/ibm80n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P80/ibm80n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P80/ibm80n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P81/ibm81n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P82/ibm82n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P83/ibm83n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P83/ibm83n02.xml [not validating:] not-wf [validating:] invalid +ibm/not-wf/P83/ibm83n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P83/ibm83n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P83/ibm83n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P83/ibm83n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n100.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n101.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n102.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n103.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n104.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n105.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n106.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n107.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n108.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n109.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n110.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n111.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n112.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n113.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n114.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n115.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n116.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n117.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n118.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n119.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n120.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n121.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n122.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n123.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n124.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n125.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n126.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n127.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n128.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n129.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n130.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n131.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n132.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n133.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n134.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n135.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n136.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n137.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n138.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n139.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n140.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n141.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n142.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n143.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n144.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n145.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n146.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n147.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n148.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n149.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n15.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n150.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n151.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n152.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n153.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n154.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n155.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n156.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n157.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n158.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n159.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n16.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n160.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n161.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n162.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n163.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n164.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n165.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n166.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n167.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n168.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n169.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n17.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n170.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n171.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n172.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n173.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n174.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n175.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n176.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n177.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n178.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n179.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n18.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n180.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n181.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n182.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n183.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n184.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n185.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n186.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n187.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n188.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n189.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n19.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n190.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n191.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n192.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n193.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n194.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n195.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n196.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n197.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n198.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n20.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n21.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n22.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n23.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n24.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n25.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n26.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n27.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n28.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n29.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n30.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n31.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n32.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n33.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n34.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n35.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n36.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n37.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n38.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n39.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n40.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n41.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n42.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n43.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n44.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n45.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n46.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n47.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n48.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n49.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n50.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n51.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n52.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n53.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n54.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n55.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n56.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n57.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n58.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n59.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n60.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n61.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n62.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n63.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n64.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n65.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n66.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n67.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n68.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n69.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n70.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n71.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n72.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n73.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n74.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n75.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n76.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n77.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n78.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n79.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n80.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n81.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n82.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n83.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n84.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n85.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n86.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n87.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n88.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n89.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n90.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n91.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n92.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n93.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n94.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n95.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n96.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n97.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n98.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P85/ibm85n99.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P86/ibm86n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P86/ibm86n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P86/ibm86n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P86/ibm86n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n15.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n16.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n17.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n18.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n19.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n20.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n21.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n22.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n23.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n24.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n25.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n26.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n27.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n28.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n29.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n30.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n31.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n32.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n33.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n34.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n35.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n36.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n37.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n38.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n39.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n40.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n41.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n42.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n43.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n44.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n45.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n46.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n47.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n48.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n49.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n50.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n51.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n52.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n53.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n54.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n55.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n56.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n57.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n58.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n59.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n60.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n61.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n62.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n63.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n64.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n66.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n67.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n68.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n69.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n70.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n71.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n72.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n73.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n74.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n75.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n76.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n77.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n78.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n79.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n80.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n81.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n82.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n83.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n84.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P87/ibm87n85.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n12.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n13.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n14.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n15.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P88/ibm88n16.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n01.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n02.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n03.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n04.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n05.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n06.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n07.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n08.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n09.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n10.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n11.xml [not validating:] not-wf [validating:] not-wf +ibm/not-wf/P89/ibm89n12.xml [not validating:] not-wf [validating:] not-wf +ibm/valid/P01/ibm01v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P02/ibm02v01.xml [not validating:] input [validating:] input +ibm/valid/P03/ibm03v01.xml [not validating:] input [validating:] input +ibm/valid/P09/ibm09v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P09/ibm09v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P09/ibm09v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P09/ibm09v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P09/ibm09v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v06.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v07.xml [not validating:] input/output [validating:] input/output +ibm/valid/P10/ibm10v08.xml [not validating:] input/output [validating:] input/output +ibm/valid/P11/ibm11v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P11/ibm11v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P11/ibm11v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P11/ibm11v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P12/ibm12v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P12/ibm12v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P12/ibm12v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P12/ibm12v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P13/ibm13v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P14/ibm14v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P14/ibm14v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P14/ibm14v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P15/ibm15v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P15/ibm15v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P15/ibm15v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P15/ibm15v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P16/ibm16v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P16/ibm16v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P16/ibm16v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P17/ibm17v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P18/ibm18v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P19/ibm19v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P20/ibm20v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P20/ibm20v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P21/ibm21v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v06.xml [not validating:] input/output [validating:] input/output +ibm/valid/P22/ibm22v07.xml [not validating:] input/output [validating:] input/output +ibm/valid/P23/ibm23v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P23/ibm23v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P23/ibm23v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P23/ibm23v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P23/ibm23v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P23/ibm23v06.xml [not validating:] input/output [validating:] input/output +ibm/valid/P24/ibm24v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P24/ibm24v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P25/ibm25v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P25/ibm25v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P25/ibm25v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P25/ibm25v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P26/ibm26v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P27/ibm27v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P27/ibm27v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P27/ibm27v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P28/ibm28v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P30/ibm30v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P30/ibm30v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P31/ibm31v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P32/ibm32v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P32/ibm32v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P32/ibm32v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P32/ibm32v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P33/ibm33v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P34/ibm34v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P35/ibm35v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P36/ibm36v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P37/ibm37v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P38/ibm38v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P39/ibm39v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P40/ibm40v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P41/ibm41v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P42/ibm42v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P43/ibm43v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P44/ibm44v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P45/ibm45v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P47/ibm47v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P49/ibm49v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P50/ibm50v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P51/ibm51v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P51/ibm51v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P52/ibm52v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P54/ibm54v01.xml [not validating:] input [validating:] input +ibm/valid/P54/ibm54v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P54/ibm54v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P55/ibm55v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v06.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v07.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v08.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v09.xml [not validating:] input/output [validating:] input/output +ibm/valid/P56/ibm56v10.xml [not validating:] input/output [validating:] input/output +ibm/valid/P57/ibm57v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P58/ibm58v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P58/ibm58v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P59/ibm59v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P59/ibm59v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P60/ibm60v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P60/ibm60v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P60/ibm60v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P60/ibm60v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P61/ibm61v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P61/ibm61v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P62/ibm62v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P62/ibm62v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P62/ibm62v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P62/ibm62v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P62/ibm62v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P63/ibm63v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P63/ibm63v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P63/ibm63v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P63/ibm63v04.xml [not validating:] input/output [validating:] input/output +ibm/valid/P63/ibm63v05.xml [not validating:] input/output [validating:] input/output +ibm/valid/P64/ibm64v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P64/ibm64v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P64/ibm64v03.xml [not validating:] input/output [validating:] input/output +ibm/valid/P65/ibm65v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P65/ibm65v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P66/ibm66v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P67/ibm67v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P68/ibm68v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P68/ibm68v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P69/ibm69v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P69/ibm69v02.xml [not validating:] input/output [validating:] input/output +ibm/valid/P70/ibm70v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P78/ibm78v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P79/ibm79v01.xml [not validating:] input [validating:] input +ibm/valid/P82/ibm82v01.xml [not validating:] input/output [validating:] input/output +ibm/valid/P85/ibm85v01.xml [not validating:] input [validating:] input +ibm/valid/P86/ibm86v01.xml [not validating:] input [validating:] input +ibm/valid/P87/ibm87v01.xml [not validating:] input [validating:] input +ibm/valid/P88/ibm88v01.xml [not validating:] input [validating:] input +ibm/valid/P89/ibm89v01.xml [not validating:] input [validating:] input +eduni/namespaces/1.0/001.xml [not validating:] input [validating:] input +eduni/namespaces/1.0/002.xml [not validating:] input [validating:] input +eduni/namespaces/1.0/003.xml [not validating:] input [validating:] input +eduni/namespaces/1.0/007.xml [not validating:] input [validating:] input +eduni/namespaces/1.0/008.xml [not validating:] input [validating:] input +eduni/namespaces/1.0/009.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/010.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/011.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/012.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/013.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/014.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/015.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/016.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/017.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/018.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/019.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/020.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/021.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/022.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/023.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/024.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/025.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/026.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/027.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/028.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/029.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/030.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/031.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/032.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/033.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/034.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/035.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/036.xml [not validating:] not-wf [validating:] invalid +eduni/namespaces/1.0/037.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/038.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/039.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/040.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/041.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/042.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/043.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/044.xml [not validating:] not-wf [validating:] not-wf +eduni/namespaces/1.0/045.xml [not validating:] input [validating:] invalid +eduni/namespaces/1.0/046.xml [not validating:] input [validating:] invalid +0/1829 tests failed; 333 tests were skipped \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/XMLS-SYMBOLS.diff =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/XMLS-SYMBOLS.diff 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/XMLS-SYMBOLS.diff 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,98 @@ +* looking for david(a)knowledgetools.de--cxml/cxml--devel--1.0--patch-309 to compare with +* comparing to david(a)knowledgetools.de--cxml/cxml--devel--1.0--patch-309 +M xml/xmls-compat.lisp + +* modified files + +--- orig/xml/xmls-compat.lisp ++++ mod/xml/xmls-compat.lisp +@@ -12,7 +12,8 @@ + (defpackage cxml-xmls + (:use :cl :runes) + (:export #:make-node #:node-name #:node-ns #:node-attrs #:node-children +- #:make-xmls-builder #:map-node)) ++ #:make-xmls-builder #:map-node ++ #:*identifier-case*)) + + (in-package :cxml-xmls) + +@@ -64,6 +65,10 @@ + + ;;;; SAX-Handler (Parser) + ++(defvar *identifier-case* nil ++ "One of NIL (don't intern names), :PRESERVE, :UPCASE, :DOWNCASE, or :INVERT ++ (intern name into the keyword package after adjusting case).") ++ + (defclass xmls-builder () + ((element-stack :initform nil :accessor element-stack) + (root :initform nil :accessor root))) +@@ -74,16 +79,46 @@ + (defmethod sax:end-document ((handler xmls-builder)) + (root handler)) + ++(defun string-invert-case (str) ++ (map 'string ++ (lambda (c) ++ (cond ++ ((upper-case-p c) (char-downcase c)) ++ ((lower-case-p c) (char-upcase c)) ++ (t c))) ++ str)) ++ ++(defun maybe-intern (name) ++ (if *identifier-case* ++ (let ((str (if (stringp name) name (rod-string name)))) ++ (intern (ecase *identifier-case* ++ (:preserve str) ++ (:upcase (string-upcase str)) ++ (:downcase (string-downcase str)) ++ (:invert (string-invert-case str))) ++ :keyword)) ++ name)) ++ ++(defun maybe-stringify (name) ++ (if (symbolp name) ++ (let ((str (symbol-name name))) ++ (ecase *identifier-case* ++ (:preserve str) ++ (:upcase (string-downcase str)) ++ (:downcase (string-upcase str)) ++ (:invert (string-invert-case str)))) ++ name)) ++ + (defmethod sax:start-element + ((handler xmls-builder) namespace-uri local-name qname attributes) + (declare (ignore namespace-uri)) + (setf local-name (or local-name qname)) + (let* ((attributes + (mapcar (lambda (attr) +- (list (sax:attribute-qname attr) ++ (list (maybe-intern (sax:attribute-qname attr)) + (sax:attribute-value attr))) + attributes)) +- (node (make-node :name local-name ++ (node (make-node :name (maybe-intern local-name) + :ns (let ((lq (length qname)) + (ll (length local-name))) + (if (eql lq ll) +@@ -124,7 +159,7 @@ + (labels ((walk (node) + (let* ((attlist + (compute-attributes node include-xmlns-attributes)) +- (lname (rod (node-name node))) ++ (lname (rod (maybe-stringify (node-name node)))) + (ns (rod (node-ns node))) + (qname (concatenate 'rod ns (rod ":") lname))) + ;; fixme: namespaces +@@ -141,6 +176,7 @@ + (remove nil + (mapcar (lambda (a) + (destructuring-bind (name value) a ++ (setf name (maybe-stringify name)) + (if (or xmlnsp (not (cxml::xmlns-attr-p (rod name)))) + (sax:make-attribute :qname (rod name) + :value (rod value) + + + Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/catalog.dtd =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/catalog.dtd 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/catalog.dtd 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,149 @@ + + +<!ENTITY % pubIdChars "CDATA"> +<!ENTITY % publicIdentifier "%pubIdChars;"> +<!ENTITY % partialPublicIdentifier "%pubIdChars;"> +<!ENTITY % uriReference "CDATA"> +<!ENTITY % string "CDATA"> +<!ENTITY % systemOrPublic "(system|public)"> + +<!ENTITY % p ""> +<!ENTITY % s ""> +<!ENTITY % nsdecl "xmlns%s;"> + +<!ENTITY % catalog "%p;catalog"> +<!ENTITY % public "%p;public"> +<!ENTITY % system "%p;system"> +<!ENTITY % uri "%p;uri"> +<!ENTITY % rewriteSystem "%p;rewriteSystem"> +<!ENTITY % rewriteURI "%p;rewriteURI"> +<!ENTITY % delegatePublic "%p;delegatePublic"> +<!ENTITY % delegateSystem "%p;delegateSystem"> +<!ENTITY % delegateURI "%p;delegateURI"> +<!ENTITY % nextCatalog "%p;nextCatalog"> +<!ENTITY % group "%p;group"> + +<!ENTITY % local.catalog.mix ""> +<!ENTITY % local.catalog.attribs ""> + +<!ELEMENT %catalog; (%public;|%system;|%uri; + |%rewriteSystem;|%rewriteURI; + |%delegatePublic;|%delegateSystem;|%delegateURI; + |%nextCatalog;|%group; %local.catalog.mix;)+> +<!ATTLIST %catalog; + %nsdecl; %uriReference; #FIXED + 'urn:oasis:names:tc:entity:xmlns:xml:catalog' + prefer %systemOrPublic; #IMPLIED + xml:base %uriReference; #IMPLIED + %local.catalog.attribs; +> + +<!ENTITY % local.public.attribs ""> + +<!ELEMENT %public; EMPTY> +<!ATTLIST %public; + id ID #IMPLIED + publicId %publicIdentifier; #REQUIRED + uri %uriReference; #REQUIRED + xml:base %uriReference; #IMPLIED + %local.public.attribs; +> + +<!ENTITY % local.system.attribs ""> + +<!ELEMENT %system; EMPTY> +<!ATTLIST %system; + id ID #IMPLIED + systemId %string; #REQUIRED + uri %uriReference; #REQUIRED + xml:base %uriReference; #IMPLIED + %local.system.attribs; +> + +<!ENTITY % local.uri.attribs ""> + +<!ELEMENT %uri; EMPTY> +<!ATTLIST %uri; + id ID #IMPLIED + name %string; #REQUIRED + uri %uriReference; #REQUIRED + xml:base %uriReference; #IMPLIED + %local.uri.attribs; +> + +<!ENTITY % local.rewriteSystem.attribs ""> + +<!ELEMENT %rewriteSystem; EMPTY> +<!ATTLIST %rewriteSystem; + id ID #IMPLIED + systemIdStartString %string; #REQUIRED + rewritePrefix %string; #REQUIRED + %local.rewriteSystem.attribs; +> + +<!ENTITY % local.rewriteURI.attribs ""> + +<!ELEMENT %rewriteURI; EMPTY> +<!ATTLIST %rewriteURI; + id ID #IMPLIED + uriStartString %string; #REQUIRED + rewritePrefix %string; #REQUIRED + %local.rewriteURI.attribs; +> + +<!ENTITY % local.delegatePublic.attribs ""> + +<!ELEMENT %delegatePublic; EMPTY> +<!ATTLIST %delegatePublic; + id ID #IMPLIED + publicIdStartString %partialPublicIdentifier; #REQUIRED + catalog %uriReference; #REQUIRED + xml:base %uriReference; #IMPLIED + %local.delegatePublic.attribs; +> + +<!ENTITY % local.delegateSystem.attribs ""> + +<!ELEMENT %delegateSystem; EMPTY> +<!ATTLIST %delegateSystem; + id ID #IMPLIED + systemIdStartString %string; #REQUIRED + catalog %uriReference; #REQUIRED + xml:base %uriReference; #IMPLIED + %local.delegateSystem.attribs; +> + +<!ENTITY % local.delegateURI.attribs ""> + +<!ELEMENT %delegateURI; EMPTY> +<!ATTLIST %delegateURI; + id ID #IMPLIED + uriStartString %string; #REQUIRED + catalog %uriReference; #REQUIRED + xml:base %uriReference; #IMPLIED + %local.delegateURI.attribs; +> + +<!ENTITY % local.nextCatalog.attribs ""> + +<!ELEMENT %nextCatalog; EMPTY> +<!ATTLIST %nextCatalog; + id ID #IMPLIED + catalog %uriReference; #REQUIRED + xml:base %uriReference; #IMPLIED + %local.nextCatalog.attribs; +> + +<!ENTITY % local.group.mix ""> +<!ENTITY % local.group.attribs ""> + +<!ELEMENT %group; (%public;|%system;|%uri; + |%rewriteSystem;|%rewriteURI; + |%delegatePublic;|%delegateSystem;|%delegateURI; + |%nextCatalog; %local.group.mix;)+> +<!ATTLIST %group; + id ID #IMPLIED + prefer %systemOrPublic; #IMPLIED + xml:base %uriReference; #IMPLIED + %local.group.attribs; +> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/Entries 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/Entries 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,2 @@ +/xhtmlgen.lisp/1.1.1.1/Sun Mar 13 18:02:57 2005// +D Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/Repository 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/Repository 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +cxml/contrib Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/Root 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/CVS/Root 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +:ext:dlichteblau@common-lisp.net:/project/cxml/cvsroot Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/xhtmlgen.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/xhtmlgen.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/contrib/xhtmlgen.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,352 @@ +;; xhtmlgen.lisp +;; This version by david(a)lichteblau.com for headcraft (http://headcraft.de/) +;; +;; Derived from htmlgen.cl: +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; +;; 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 AllegroServe +;; prequel found in license-allegroserve.txt. +;; +;; 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. +;; +;; Version 2.1 of the GNU Lesser General Public License is in the file +;; license-lgpl.txt that was distributed with this file. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA + +(defpackage :xhtml-generator + (:use :common-lisp) + (:export #:with-html #:write-doctype)) + +(in-package :xhtml-generator) + +;; html generation + +(defstruct (html-process (:type list) (:constructor + make-html-process (key macro special + name-attr + ))) + key ; keyword naming this tag + macro ; the macro to define this + special ; if true then call this to process the keyword and return + ; the macroexpansion + name-attr ; attribute symbols which can name this object for subst purposes + ) + + +(defparameter *html-process-table* + (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes + ) + +(defvar *html-sink*) + +(defun write-doctype (sink) + (sax:start-dtd sink + "html" + "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") + (sax:end-dtd sink)) + +(defmacro with-html (sink &rest forms &environment env) + `(let ((*html-sink* ,sink)) + ,(process-html-forms forms env))) + +(defun get-process (form) + (let ((ent (gethash form *html-process-table*))) + (unless ent + (error "unknown html keyword ~s" form)) + ent)) + +(defun process-html-forms (forms env) + (let (res) + (flet ((do-ent (ent args argsp body) + ;; ent is an html-process object associated with the + ;; html tag we're processing + ;; args is the list of values after the tag in the form + ;; ((:tag &rest args) ....) + ;; argsp is true if this isn't a singleton tag (i.e. it has + ;; a body) .. (:tag ...) or ((:tag ...) ...) + ;; body is the body if any of the form + ;; + (let ((special (html-process-special ent))) + (push (if special + (funcall special ent args argsp body) + `(,(html-process-macro ent) + ,args + ,(process-html-forms body env))) + res)))) + (do* ((xforms forms (cdr xforms)) + (form (car xforms) (car xforms))) + ((null xforms)) + + (setq form (macroexpand form env)) + + (if (atom form) + (typecase form + (keyword (do-ent (get-process form) nil nil nil)) + (string (push `(sax:characters *html-sink* ,form) res)) + (t (push form res))) + (let ((first (car form))) + (cond + ((keywordp first) + ;; (:xxx . body) form + (do-ent (get-process (car form)) nil t (cdr form))) + ((and (consp first) (keywordp (car first))) + ;; ((:xxx args ) . body) + (do-ent (get-process (caar form)) (cdr first) t (cdr form))) + (t + (push form res))))))) + `(progn ,@(nreverse res)))) + +(defun html-body-key-form (string-code args body) + (unless (evenp (length args)) + (error "attribute list ~S isn't even" args)) + `(let ((.tagname. ,string-code)) + (sax:start-element *html-sink* nil nil .tagname. + (list + ,@(loop + for (name value) on args by #'cddr + collect + `(sax:make-attribute + :qname ,(etypecase name + (symbol (symbol-name name)) + (string name)) + :value ,value + :specified-p t)))) + ,@body + (sax:end-element *html-sink* nil nil .tagname.))) + +(defun emit-without-quoting (str) + (let ((s (cxml::chained-handler *html-sink*))) + (cxml::maybe-close-tag s) + (map nil (lambda (c) (cxml::write-rune (char-code c) s)) str))) + +(defun princ-http (val) + (warn "use of deprecated :PRINC (use :PRINC-SAFE instead?)") + (emit-without-quoting (princ-to-string val))) + +(defun prin1-http (val) + (warn "use of deprecated :PRIN1 (use :PRIN1-SAFE instead?)") + (emit-without-quoting (prin1-to-string val))) + +(defun princ-safe-http (val) + (sax:characters *html-sink* (princ-to-string val))) + +(defun prin1-safe-http (val) + (sax:characters *html-sink* (prin1-to-string val))) + + +;; -- defining how html tags are handled. -- +;; +;; most tags are handled in a standard way and the def-std-html +;; macro is used to define such tags +;; +;; Some tags need special treatment and def-special-html defines +;; how these are handled. The tags requiring special treatment +;; are the pseudo tags we added to control operations +;; in the html generator. +;; +;; +;; tags can be found in three ways: +;; :br - singleton, no attributes, no body +;; (:b "foo") - no attributes but with a body +;; ((:a href="foo") "balh") - attributes and body +;; + +(defmacro def-special-html (kwd fcn) + ;; kwd - the tag we're defining behavior for. + ;; fcn - function to compute the macroexpansion of a use of this + ;; tag. args to fcn are: + ;; ent - html-process object holding info on this tag + ;; args - list of attribute-values following tag + ;; argsp - true if there is a body in this use of the tag + ;; body - list of body forms. + `(setf (gethash ,kwd *html-process-table*) + (make-html-process ,kwd nil ,fcn nil))) + +(def-special-html :newline + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + (when body + (error "can't have a body with :newline -- body is ~s" body)) + (emit-without-quoting (string #\newline)))) + +(def-special-html :princ + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(princ-http ,bod)) + body)))) + +(def-special-html :princ-safe + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(princ-safe-http ,bod)) + body)))) + +(def-special-html :prin1 + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(prin1-http ,bod)) + body)))) + +(def-special-html :prin1-safe + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(prin1-safe-http ,bod)) + body)))) + +(def-special-html :comment + #'(lambda (ent args argsp body) + (declare (ignore ent args argsp body)) + `(warn ":COMMENT in html macro not supported yet"))) + +(defmacro def-std-html (kwd name-attrs) + (let ((mac-name (intern (format nil "~a-~a" :with-html kwd))) + (string-code (string-downcase (string kwd)))) + `(progn (setf (gethash ,kwd *html-process-table*) + (make-html-process ,kwd + ',mac-name + nil + ',name-attrs)) + (defmacro ,mac-name (args &rest body) + (html-body-key-form ,string-code args body))))) + +(def-std-html :a nil) +(def-std-html :abbr nil) +(def-std-html :acronym nil) +(def-std-html :address nil) +(def-std-html :applet nil) +(def-std-html :area nil) + +(def-std-html :b nil) +(def-std-html :base nil) +(def-std-html :basefont nil) +(def-std-html :bdo nil) +(def-std-html :bgsound nil) +(def-std-html :big nil) +(def-std-html :blink nil) +(def-std-html :blockquote nil) +(def-std-html :body nil) +(def-std-html :br nil) +(def-std-html :button nil) + +(def-std-html :caption nil) +(def-std-html :center nil) +(def-std-html :cite nil) +(def-std-html :code nil) +(def-std-html :col nil) +(def-std-html :colgroup nil) + +(def-std-html :dd nil) +(def-std-html :del nil) +(def-std-html :dfn nil) +(def-std-html :dir nil) +(def-std-html :div nil) +(def-std-html :dl nil) +(def-std-html :dt nil) + +(def-std-html :em nil) +(def-std-html :embed nil) + +(def-std-html :fieldset nil) +(def-std-html :font nil) +(def-std-html :form :name) +(def-std-html :frame nil) +(def-std-html :frameset nil) + +(def-std-html :h1 nil) +(def-std-html :h2 nil) +(def-std-html :h3 nil) +(def-std-html :h4 nil) +(def-std-html :h5 nil) +(def-std-html :h6 nil) +(def-std-html :head nil) +(def-std-html :hr nil) +(def-std-html :html nil) + +(def-std-html :i nil) +(def-std-html :iframe nil) +(def-std-html :ilayer nil) +(def-std-html :img :id) +(def-std-html :input nil) +(def-std-html :ins nil) +(def-std-html :isindex nil) + +(def-std-html :kbd nil) +(def-std-html :keygen nil) + +(def-std-html :label nil) +(def-std-html :layer nil) +(def-std-html :legend nil) +(def-std-html :li nil) +(def-std-html :link nil) +(def-std-html :listing nil) + +(def-std-html :map nil) +(def-std-html :marquee nil) +(def-std-html :menu nil) +(def-std-html :meta nil) +(def-std-html :multicol nil) + +(def-std-html :nobr nil) +(def-std-html :noembed nil) +(def-std-html :noframes nil) +(def-std-html :noscript nil) + +(def-std-html :object nil) +(def-std-html :ol nil) +(def-std-html :optgroup nil) +(def-std-html :option nil) + +(def-std-html :p nil) +(def-std-html :param nil) +(def-std-html :plaintext nil) +(def-std-html :pre nil) + +(def-std-html :q nil) + +(def-std-html :s nil) +(def-std-html :samp nil) +(def-std-html :script nil) +(def-std-html :select nil) +(def-std-html :server nil) +(def-std-html :small nil) +(def-std-html :spacer nil) +(def-std-html :span :id) +(def-std-html :strike nil) +(def-std-html :strong nil) +(def-std-html :style nil) +(def-std-html :sub nil) +(def-std-html :sup nil) + +(def-std-html :table :name) +(def-std-html :tbody nil) +(def-std-html :td nil) +(def-std-html :textarea nil) +(def-std-html :tfoot nil) +(def-std-html :th nil) +(def-std-html :thead nil) +(def-std-html :title nil) +(def-std-html :tr nil) +(def-std-html :tt nil) + +(def-std-html :u nil) +(def-std-html :ul nil) + +(def-std-html :var nil) + +(def-std-html :wbr nil) + +(def-std-html :xmp nil) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/cxml.asd =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/cxml.asd 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/cxml.asd 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,102 @@ +(defpackage :cxml-system + (:use :asdf :cl)) +(in-package :cxml-system) + +;; force loading of runes.asd, which installs *features* this file depends on +(find-system :runes) + +(defclass closure-source-file (cl-source-file) ()) + +#+scl +(pushnew 'uri-is-namestring *features*) + +#+sbcl +(defmethod perform :around ((o compile-op) (s closure-source-file)) + ;; shut up already. Correctness first. + (handler-bind ((sb-ext:compiler-note #'muffle-warning)) + (let (#+sbcl (*compile-print* nil)) + (call-next-method)))) + +(asdf:defsystem :cxml-xml + :default-component-class closure-source-file + :pathname (merge-pathnames + "xml/" + (make-pathname :name nil :type nil :defaults *load-truename*)) + :components + ((:file "package") + (:file "util" :depends-on ("package")) + (:file "sax-handler") + (:file "xml-name-rune-p" :depends-on ("package" "util")) + (:file "split-sequence" :depends-on ("package")) + (:file "xml-parse" :depends-on ("package" "util" "sax-handler" "split-sequence" "xml-name-rune-p")) + (:file "unparse" :depends-on ("xml-parse")) + (:file "xmls-compat" :depends-on ("xml-parse")) + (:file "recoder" :depends-on ("xml-parse")) + (:file "xmlns-normalizer" :depends-on ("xml-parse")) + (:file "space-normalizer" :depends-on ("xml-parse")) + (:file "catalog" :depends-on ("xml-parse")) + (:file "sax-proxy" :depends-on ("xml-parse"))) + :depends-on (:runes :puri #-scl :trivial-gray-streams)) + +(defclass utf8dom-file (closure-source-file) ((of))) + +(defmethod output-files ((operation compile-op) (c utf8dom-file)) + (let* ((normal (car (call-next-method))) + (name (concatenate 'string (pathname-name normal) "-utf8"))) + (list (make-pathname :name name :defaults normal)))) + +;; must be an extra method because of common-lisp-controller's :around method +(defmethod output-files :around ((operation compile-op) (c utf8dom-file)) + (let ((x (call-next-method))) + (setf (slot-value c 'of) (car x)) + x)) + +(defmethod perform ((o load-op) (c utf8dom-file)) + (load (slot-value c 'of))) + +(defmethod perform ((operation compile-op) (c utf8dom-file)) + (let ((*features* (cons 'utf8dom-file *features*)) + (*readtable* + (symbol-value (find-symbol "*UTF8-RUNES-READTABLE*" :runes-system)))) + (call-next-method))) + +(asdf:defsystem :cxml-dom + :default-component-class closure-source-file + :pathname (merge-pathnames + "dom/" + (make-pathname :name nil :type nil :defaults *load-truename*)) + :components + ((:file "package") + (:file rune-impl :pathname "dom-impl" :depends-on ("package")) + (:file rune-builder :pathname "dom-builder" :depends-on (rune-impl)) + #+rune-is-integer + (utf8dom-file utf8-impl :pathname "dom-impl" :depends-on ("package")) + #+rune-is-integer + (utf8dom-file utf8-builder :pathname "dom-builder" :depends-on (utf8-impl)) + (:file "dom-sax" :depends-on ("package"))) + :depends-on (:cxml-xml)) + +(asdf:defsystem :cxml-klacks + :default-component-class closure-source-file + :pathname (merge-pathnames + "klacks/" + (make-pathname :name nil :type nil :defaults *load-truename*)) + :serial t + :components + ((:file "package") + (:file "klacks") + (:file "klacks-impl") + (:file "tap-source")) + :depends-on (:cxml-xml)) + +(asdf:defsystem :cxml-test + :default-component-class closure-source-file + :pathname (merge-pathnames + "test/" + (make-pathname :name nil :type nil :defaults *load-truename*)) + :components ((:file "domtest") (:file "xmlconf")) + :depends-on (:cxml-xml :cxml-klacks :cxml-dom)) + +(asdf:defsystem :cxml + :components () + :depends-on (:cxml-dom :cxml-klacks :cxml-test)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/Entries 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/Entries 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,12 @@ +/GNUmakefile/1.4/Sun Jul 22 19:59:26 2007// +/bg.png/1.1/Fri Dec 30 16:06:33 2005/-kb/ +/cxml.css/1.8/Tue May 1 18:21:40 2007// +/dom.xml/1.1/Sun Feb 18 12:35:50 2007// +/html.xsl/1.5/Tue May 1 18:21:40 2007// +/index.xml/1.16/Sun Aug 5 12:01:23 2007// +/installation.xml/1.3/Sat May 26 21:55:58 2007// +/klacks.xml/1.9/Sun Apr 22 13:23:54 2007// +/quickstart.xml/1.2/Tue May 1 18:21:40 2007// +/sax.xml/1.6/Sat Jul 7 20:47:38 2007// +/xmls-compat.xml/1.2/Sat Jun 16 11:07:58 2007// +D Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/Repository 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/Repository 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +cxml/doc Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/Root 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/CVS/Root 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +:ext:dlichteblau@common-lisp.net:/project/cxml/cvsroot Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/GNUmakefile =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/GNUmakefile 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/GNUmakefile 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,6 @@ +all: dom.html index.html installation.html klacks.html quickstart.html sax.html xmls-compat.html + +%.html: %.xml html.xsl + xsltproc html.xsl $< >$@.tmp + mv $@.tmp $@ + chmod -w $@ Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/bg.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/bg.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/cxml.css =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/cxml.css 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/cxml.css 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,90 @@ +div.sidebar { + float: right; + min-width: 15%; + padding: 0pt 5pt 5pt 5pt; + font-family: verdana, arial; +} + +div.sidebar-title { + font-weight: bold; + background-color: #9c0000; + border: solid #9c0000; + border-top-width: 1px; + border-bottom-width: 2px; + border-left-width: 4px; + border-right-width: 0px; + padding-left: 1px; + margin: 0em 2pt 0px 2em; +} + +div.sidebar-title a { + color: #ffffff; +} + +div.sidebar-main { + background-color: #f7f7f7; + border: solid #9c0000; + border-top-width: 0px; + border-bottom-width: 0px; + border-left-width: 4px; + border-right-width: 0px; + margin: 0em 2pt 1em 2em; + padding: 1em; +} + +div.sidebar ul.main { + padding: 0pt 0pt 0pt 1em; + margin: 0 0 1em; +} + +div.sidebar ul.sub { + list-style-type: square; + padding: 0pt 0pt 0pt 1em; + margin: 0 0 1em; +} + +div.sidebar ul.hack { + padding: 0 0 0 0; + margin: 0 0 1em; + list-style-type: none; +} + +body { + color: #000000; + background-color: #ffffff; + margin-right: 0pt; + margin-bottom: 10%; + margin-left: 40px; + padding-left: 30px; + font-family: verdana, arial; + background-image: url(bg.png); + background-position: top left; + background-attachment: fixed; + background-repeat: no-repeat; +} + +h1 { + margin-left: -30px; +} + +h2,h3 { + margin-left: -30px; + margin-top: 2em; +} + +pre { + background-color: #eeeeee; + border: solid 1px #d0d0d0; + padding: 1em; + margin-right: 10%; +} + +.def { + background-color: #ddddff; + font-weight: bold; +} + +.nomargin { + margin-bottom: 0; + margin-top: 0; +} Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/dom.html =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/dom.html 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/dom.html 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,198 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"> +<html> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> +<title>CXML W3C DOM</title> +<link rel="stylesheet" type="text/css" href="cxml.css"> +</head> +<body> +<div class="sidebar"> +<div class="sidebar-title"><a href="index.html">Closure XML</a></div> +<div class="sidebar-main"><ul class="main"> +<li> +<a href="installation.html">Installing Closure XML</a><ul class="sub"> +<li><a href="installation.html#download"><b>Download</b></a></li> +<li><a href="installation.html#implementations">Implementation-specific notes</a></li> +<li><a href="installation.html#compilation">Compilation</a></li> +<li><a href="installation.html#tests">Tests</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li> +<li> +<a href="sax.html">SAX parsing and serialization</a><ul class="sub"> +<li><a href="sax.html#parser">Parsing and Validating</a></li> +<li><a href="sax.html#serialization">Serialization</a></li> +<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li> +<li><a href="sax.html#rods">Recoders</a></li> +<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li> +<li><a href="sax.html#catalogs">XML Catalogs</a></li> +<li><a href="sax.html#sax">SAX Interface</a></li> +</ul> +</li> +<li> +<a href="klacks.html">Klacks parser</a><ul class="sub"> +<li><a href="klacks.html#sources">Parsing incrementally</a></li> +<li><a href="klacks.html#convenience">Convenience functions</a></li> +<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li> +<li><a href="klacks.html#locator">Location information</a></li> +<li><a href="klacks.html#klacksax">Examples</a></li> +</ul> +</li> +<li> +<a href="dom.html">DOM implementation</a><ul class="sub"> +<li><a href="dom.html#parser">Parsing with the DOM builder</a></li> +<li><a href="dom.html#serialization">Serialization</a></li> +<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li> +</ul></div> +</div> + <h1>W3C DOM</h1> + <p> + CXML implements the DOM Level 2 Core interfaces. For details + on DOM, please refer to the <a href="http://www.w3.org/TR/DOM-Level-2-Core/core.html">specification</a>. + </p> + + <a name="parser"></a> + <h3>Parsing into DOM</h3> + <p> + To parse an XML document into a DOM tree, use the SAX parser with a + DOM builder as the SAX handler. Example: + </p> + <pre>(cxml:parse-file "test.xml" (cxml-dom:make-dom-builder))</pre> + <p> + <div class="def">Function CXML-DOM:MAKE-DOM-BUILDER ()</div> + Create a SAX handler which builds a DOM document. + <p> + </p> + This functions returns a DOM builder that will work with the default + configuration of the SAX parser and is guaranteed to use + characters/strings instead of runes/rods, if that makes a + difference on the Lisp in question. + <p> + </p> + This is the same as <tt>rune-dom:make-dom-builder</tt> on Lisps + with Unicode support, and the same as + <tt>utf8-dom:make-dom-builder</tt> otherwise. + </p> + + <p> + <div class="def">Function RUNE-DOM:MAKE-DOM-BUILDER ()</div> + Create a SAX handler which builds a DOM document using runes and rods. + </p> + + <p> + <div class="def">Function UTF8-DOM:MAKE-DOM-BUILDER ()</div> + (Only on Lisps without Unicode support:) + Create a SAX handler which builds a DOM document using + UTF-8-encoded strings. + </p> + + <a name="serialization"></a> + <h3>Serializing DOM</h3> + <p> + To serialize a DOM document, use a SAX serialization sink as the + argument to <tt>dom:map-document</tt>, which generates SAX events + for the DOM tree. + </p> + <p> + Applications dealing with namespaces might want to inject a + <a href="sax.html#misc">namespace normalizer</a> into the + sink chain. + </p> + <p> + <div class="def">Function DOM:MAP-DOCUMENT (handler document &key include-xmlns-attributes include-default-values include-doctype)</div> + Traverse a DOM document and call SAX functions as if an XML + representation of the document was processed by a SAX parser. + </p> + <p>Keyword arguments:</p> + <ul> + <li> + <tt>include-xmlns-attributes</tt> -- defaults to + <tt>sax:*include-xmlns-attributes*</tt> + </li> + <li> + <tt>include-doctype</tt> -- One of <tt>nil</tt> (no doctype + declaration), <tt>:full-internal-subset</tt> (include a doctype + declaration and the full internal subset), or + <tt>:canonical-notations</tt> (write a doctype declaration + with an internal subset including only notations, as required + for canonical serialization). + </li> + <li> + <tt>include-default-values</tt> -- include attribute nodes with nil + <tt>dom:specified</tt>. + </li> + <li> + <tt>recode</tt> -- (ignored on Lisps with Unicode support.) If + true, recode UTF-8 strings to rods. Defaults to true if used + with a UTF-8 DOM document. It can be set to false manually to + suppress recoding in this case. + </li> + </ul> + + <a name="mapping"></a> + <h3>DOM/Lisp mapping</h3> + <p> + Note that there is no "standard" DOM mapping for Lisp. + </p> + <p> + DOM is <a href="http://www.w3.org/TR/DOM-Level-2-Core/idl-definitions.html">specified + in CORBA IDL</a>, but it refrains from using object-oriented IDL + features, allowing for a much more natural Lisp implemenation than + the the ordinary IDL/Lisp mapping would. + Differences between CXML's DOM and the direct IDL/Lisp mapping: + </p> + <ul> + <li> + DOM function names are symbols in the <tt>DOM</tt> package (not + the <tt>OP</tt> package). + </li> + <li> + DOM functions have proper required arguments, not a huge + <tt>&rest</tt> lambda list. + </li> + <li> + Although most IDL interfaces are implemented as CLOS classes by + CXML, the Lisp types of DOM objects is not documented and cannot + be relied upon. A node's type can be determined using + <tt>dom:node-type</tt> instead. + </li> + <li> + <tt>DOMString</tt> is mapped to <tt>rod</tt>, which is either + an <tt>(unsigned-byte 16)</tt> array type or a string type. + </li> + <li> + The IDL/Lisp mapping maps CORBA enums to Lisp keywords. + Unfortunately, the DOM IDL does not use enums. Instead, + both exception types and node types are defined integer + constants. CXML chooses to ignore this definition and uses + keywords instead. + </li> + <li> + DOM uses StudlyCaps. Lisp programmers don't. We + insert <tt>#\-</tt> before every upper case letter preceded by a + lower case letter and before every upper case letter which is + followed by a lower case letter, but preceded by a capital + letter. This algorithms leads to the natural Lisp spelling + of DOM function names. + </li> + <li> + Implementation note: DOM's <tt>NodeList</tt> does not + necessarily map to a native "sequence" type. (For example, + node lists are objects in Java, not arrays.) + <tt>NodeList</tt> is specified to reflect changes done after a + node list was created, so node lists cannot be Lisp lists. + (A node list could be implemented as a CLOS object pointing to + said list though.) Instead, CXML currently implements node + lists as adjustable vectors. Note that code which relies on + this implementation and uses Lisp sequence functions + instead of sticking to <tt>dom:item</tt> and <tt>dom:length</tt> + is not portable. As a compromise, you can use our + extensions <tt>dom:map-node-list</tt> or + <tt>dom:do-node-list</tt>, which can be implemented portably. + </li> + </ul> +</body> +</html> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/dom.xml =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/dom.xml 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/dom.xml 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,150 @@ +<documentation title="CXML W3C DOM"> + <h1>W3C DOM</h1> + <p> + CXML implements the DOM Level 2 Core interfaces.  For details + on DOM, please refer to the <a + href="http://www.w3.org/TR/DOM-Level-2-Core/core.html">specification</a>. + </p> + + <a name="parser"/> + <h3>Parsing into DOM</h3> + <p> + To parse an XML document into a DOM tree, use the SAX parser with a + DOM builder as the SAX handler. Example: + </p> + <pre>(cxml:parse-file "test.xml" (cxml-dom:make-dom-builder))</pre> + <p> + <div class="def">Function CXML-DOM:MAKE-DOM-BUILDER ()</div> + Create a SAX handler which builds a DOM document. + <p> + </p> + This functions returns a DOM builder that will work with the default + configuration of the SAX parser and is guaranteed to use + characters/strings instead of runes/rods, if that makes a + difference on the Lisp in question. + <p> + </p> + This is the same as <tt>rune-dom:make-dom-builder</tt> on Lisps + with Unicode support, and the same as + <tt>utf8-dom:make-dom-builder</tt> otherwise. + </p> + + <p> + <div class="def">Function RUNE-DOM:MAKE-DOM-BUILDER ()</div> + Create a SAX handler which builds a DOM document using runes and rods. + </p> + + <p> + <div class="def">Function UTF8-DOM:MAKE-DOM-BUILDER ()</div> + (Only on Lisps without Unicode support:) + Create a SAX handler which builds a DOM document using + UTF-8-encoded strings. + </p> + + <a name="serialization"/> + <h3>Serializing DOM</h3> + <p> + To serialize a DOM document, use a SAX serialization sink as the + argument to <tt>dom:map-document</tt>, which generates SAX events + for the DOM tree. + </p> + <p> + Applications dealing with namespaces might want to inject a + <a href="sax.html#misc">namespace normalizer</a> into the + sink chain. + </p> + <p> + <div class="def">Function DOM:MAP-DOCUMENT (handler document &key include-xmlns-attributes include-default-values include-doctype)</div> + Traverse a DOM document and call SAX functions as if an XML + representation of the document was processed by a SAX parser. + </p> + <p>Keyword arguments:</p> + <ul> + <li> + <tt>include-xmlns-attributes</tt> -- defaults to + <tt>sax:*include-xmlns-attributes*</tt> + </li> + <li> + <tt>include-doctype</tt> -- One of <tt>nil</tt> (no doctype + declaration), <tt>:full-internal-subset</tt> (include a doctype + declaration and the full internal subset), or + <tt>:canonical-notations</tt> (write a doctype declaration + with an internal subset including only notations, as required + for canonical serialization). + </li> + <li> + <tt>include-default-values</tt> -- include attribute nodes with nil + <tt>dom:specified</tt>. + </li> + <li> + <tt>recode</tt> -- (ignored on Lisps with Unicode support.) If + true, recode UTF-8 strings to rods. Defaults to true if used + with a UTF-8 DOM document. It can be set to false manually to + suppress recoding in this case. + </li> + </ul> + + <a name="mapping"/> + <h3>DOM/Lisp mapping</h3> + <p> + Note that there is no "standard" DOM mapping for Lisp. + </p> + <p> + DOM is <a + href="http://www.w3.org/TR/DOM-Level-2-Core/idl-definitions.html">specified + in CORBA IDL</a>, but it refrains from using object-oriented IDL + features, allowing for a much more natural Lisp implemenation than + the the ordinary IDL/Lisp mapping would.  + Differences between CXML's DOM and the direct IDL/Lisp mapping: + </p> + <ul> + <li> + DOM function names are symbols in the <tt>DOM</tt> package (not + the <tt>OP</tt> package). + </li> + <li> + DOM functions have proper required arguments, not a huge + <tt>&rest</tt> lambda list. + </li> + <li> + Although most IDL interfaces are implemented as CLOS classes by + CXML, the Lisp types of DOM objects is not documented and cannot + be relied upon.  A node's type can be determined using + <tt>dom:node-type</tt> instead. + </li> + <li> + <tt>DOMString</tt> is mapped to <tt>rod</tt>, which is either + an <tt>(unsigned-byte 16)</tt> array type or a string type. + </li> + <li> + The IDL/Lisp mapping maps CORBA enums to Lisp keywords.  + Unfortunately, the DOM IDL does not use enums.  Instead, + both exception types and node types are defined integer + constants.  CXML chooses to ignore this definition and uses + keywords instead. + </li> + <li> + DOM uses StudlyCaps.  Lisp programmers don't.  We + insert <tt>#\-</tt> before every upper case letter preceded by a + lower case letter and before every upper case letter which is + followed by a lower case letter, but preceded by a capital + letter.  This algorithms leads to the natural Lisp spelling + of DOM function names. + </li> + <li> + Implementation note: DOM's <tt>NodeList</tt> does not + necessarily map to a native "sequence" type.  (For example, + node lists are objects in Java, not arrays.)  + <tt>NodeList</tt> is specified to reflect changes done after a + node list was created, so node lists cannot be Lisp lists.  + (A node list could be implemented as a CLOS object pointing to + said list though.)  Instead, CXML currently implements node + lists as adjustable vectors.  Note that code which relies on + this implementation and uses Lisp sequence functions + instead of sticking to <tt>dom:item</tt> and <tt>dom:length</tt> + is not portable.  As a compromise, you can use our + extensions <tt>dom:map-node-list</tt> or + <tt>dom:do-node-list</tt>, which can be implemented portably. + </li> + </ul> +</documentation> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/html.xsl =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/html.xsl 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/html.xsl 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,110 @@ +<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0"> + <xsl:output method="html" + indent="yes" + doctype-public="-//W3C//DTD HTML 4.01 Transitional//EN" + doctype-system="http://www.w3.org/TR/html4/loose.dtd"/> + + <xsl:template match="@*|node()"> + <xsl:copy> + <xsl:apply-templates select="@*|node()"/> + </xsl:copy> + </xsl:template> + + <xsl:template match="documentation"> + <html> + <head> + <title> + <xsl:value-of select="@title"/> + </title> + <link rel="stylesheet" type="text/css" href="cxml.css"/> + <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/> + </head> + <body> + <div class="sidebar"> + <div class="sidebar-title"> + <a href="index.html">Closure XML</a> + </div> + <div class="sidebar-main"> + <ul class="main"> + <li> + <a href="installation.html">Installing Closure XML</a> + <ul class="sub"> + <li><a href="installation.html#download"><b>Download</b></a></li> + <li><a href="installation.html#implementations">Implementation-specific notes</a></li> + <li><a href="installation.html#compilation">Compilation</a></li> + <li><a href="installation.html#tests">Tests</a></li> + </ul> + </li> + <li> + <ul class="hack"> + <li> + <a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a> + </li> + </ul> + </li> + <li> + <a href="sax.html">SAX parsing and serialization</a> + <ul class="sub"> + <li><a href="sax.html#parser">Parsing and Validating</a></li> + <li><a href="sax.html#serialization">Serialization</a></li> + <li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li> + <li><a href="sax.html#rods">Recoders</a></li> + <li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li> + <li><a href="sax.html#catalogs">XML Catalogs</a></li> + <li><a href="sax.html#sax">SAX Interface</a></li> + </ul> + </li> + <li> + <a href="klacks.html">Klacks parser</a> + <ul class="sub"> + <li><a href="klacks.html#sources">Parsing incrementally</a></li> + <li><a href="klacks.html#convenience">Convenience functions</a></li> + <li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li> + <li><a href="klacks.html#locator">Location information</a></li> + <li><a href="klacks.html#klacksax">Examples</a></li> + </ul> + </li> + <li> + <a href="dom.html">DOM implementation</a> + <ul class="sub"> + <li><a href="dom.html#parser">Parsing with the DOM builder</a></li> + <li><a href="dom.html#serialization">Serialization</a></li> + <li><a href="dom.html#mapping">DOM/Lisp mapping</a></li> + </ul> + </li> + <li> + <ul class="hack"> + <li><a href="xmls-compat.html">XMLS Builder</a></li> + </ul> + </li> + </ul> + </div> + </div> + <xsl:apply-templates/> + </body> + </html> + </xsl:template> + + <xsl:template match="page-index"> + <ul> + <xsl:for-each select="//heading"> + <li> + <a href="#{generate-id()}"> + <xsl:copy> + <xsl:apply-templates select="node()"/> + </xsl:copy> + </a> + </li> + </xsl:for-each> + </ul> + </xsl:template> + + <xsl:template match="heading"> + <a name="{generate-id()}"/> + <h3> + <xsl:copy> + <xsl:apply-templates select="node()"/> + </xsl:copy> + </h3> + </xsl:template> +</xsl:stylesheet> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/index.html =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/index.html 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/index.html 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,218 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"> +<html> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> +<title>Closure XML</title> +<link rel="stylesheet" type="text/css" href="cxml.css"> +</head> +<body> +<div class="sidebar"> +<div class="sidebar-title"><a href="index.html">Closure XML</a></div> +<div class="sidebar-main"><ul class="main"> +<li> +<a href="installation.html">Installing Closure XML</a><ul class="sub"> +<li><a href="installation.html#download"><b>Download</b></a></li> +<li><a href="installation.html#implementations">Implementation-specific notes</a></li> +<li><a href="installation.html#compilation">Compilation</a></li> +<li><a href="installation.html#tests">Tests</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li> +<li> +<a href="sax.html">SAX parsing and serialization</a><ul class="sub"> +<li><a href="sax.html#parser">Parsing and Validating</a></li> +<li><a href="sax.html#serialization">Serialization</a></li> +<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li> +<li><a href="sax.html#rods">Recoders</a></li> +<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li> +<li><a href="sax.html#catalogs">XML Catalogs</a></li> +<li><a href="sax.html#sax">SAX Interface</a></li> +</ul> +</li> +<li> +<a href="klacks.html">Klacks parser</a><ul class="sub"> +<li><a href="klacks.html#sources">Parsing incrementally</a></li> +<li><a href="klacks.html#convenience">Convenience functions</a></li> +<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li> +<li><a href="klacks.html#locator">Location information</a></li> +<li><a href="klacks.html#klacksax">Examples</a></li> +</ul> +</li> +<li> +<a href="dom.html">DOM implementation</a><ul class="sub"> +<li><a href="dom.html#parser">Parsing with the DOM builder</a></li> +<li><a href="dom.html#serialization">Serialization</a></li> +<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li> +</ul></div> +</div> + <h1>Closure XML Parser</h1> + + <p>An XML parser written in Common Lisp.</p> + + <p> + Closure XML was written + by <a href="http://www.stud.uni-karlsruhe.de/~unk6/">Gilbert + Baumann</a> as part of the Closure web browser and is now + maintained by + <a href="mailto:david@lichteblau.com">David Lichteblau</a>. + It is licensed under Lisp-LGPL. + </p> + + <p> + CXML implements a <a href="http://www.w3.org/TR/REC-xml-names/">namespace-aware</a>, + validating <a href="http://www.w3.org/TR/2000/REC-xml-20001006">XML 1.0</a> + parser as well as the <a href="http://www.w3.org/TR/DOM-Level-2-Core/">DOM Level 2 Core</a> + interfaces. Two parser interfaces are offered, one SAX-like, the + other similar to StAX. + </p> + + <p> + Send bug reports to <a href="mailto:cxml-devel@common-lisp.net">cxml-devel(a)common-lisp.net</a> + (<a href="http://common-lisp.net/cgi-bin/mailman/listinfo/cxml-devel">list + information</a>). + </p> + + <h3>Add-on features</h3> + <p> + The following libraries are available as separate downloads: + </p> + <p> + ⬗ + <a href="http://www.lichteblau.com/cxml-rng/">cxml-rng</a> + + Relax NG validation + </p> + <p> + ⬗ + <a href="http://www.lichteblau.com/cxml-stp/">cxml-stp</a> + + STP, an alternative to DOM + </p> + + + <a name="changes"></a> + <h3>Recent Changes</h3> + <p class="nomargin"><tt>rel-2007-08-05</tt></p> + <ul class="nomargin"> + <li>Various DTD serialization fixes</li> + <li>UTF-8 fix, thanks to Francis Leboutte</li> + </ul> + <p class="nomargin"><tt>rel-2007-07-07</tt></p> + <ul class="nomargin"> + <li> + Fixed build on non-Unicode lisps. Fixed parsing on + non-Unicode lisps. Fixed Unicode detection on OpenMCL. + </li> + <li>New function <tt>cxml:parse</tt>.</li> + <li>Serialization no longer defaults to canonical form.</li> + <li>Fixed octet array argument to make-source.</li> + <li> + XMLS compatibility is not <i>bug-for-bug</i>-compatible with + XMLS any more. There is now a mode using pairs of local name + and namespace URI, and a second mode using qualified names + only. The old behaviour using pairs of prefix and local names + was removed. (Thanks to Douglas Crosher.) + </li> + <li> + SCL support (thanks to Douglas Crosher). Includes support for + implementations where URIs are valid namestrings, and a mode + where normal streams are used instead of xstreams and ystreams + (albeit both SCL-specific at this point). + </li> + <li>new convenience serialization function cxml:doctype. Various + DTD serialization fixes.</li> + </ul> + <p class="nomargin"><tt>rel-2007-05-26</tt></p> + <ul class="nomargin"> + <li>cxml.asd has been split up into <tt>cxml.asd</tt> for the + XML parser and <tt>runes.asd</tt> for the runes package, in + preparation of a complete split of the two systems. Future CXML + releases will use separate tarballs for <tt>runes</tt> + and <tt>cxml</tt>.</li> + <li>xml:base support (SAX and Klacks only, not yet used in DOM). + See documentation <a href="sax.html#saxparser">here</a> and <a href="klacks.html#locator">here</a>.</li> + <li>New class <tt>broadcast-handler</tt> as a generalization + of the older <tt>sax-proxy</tt>.</li> + <li>New class <tt>tapping-source</tt>, a klacks source that + relays events from an upstream klacks source unchanged, while also + emitting them as SAX events to a user-specified handler at the + same time.</li> + <li>Changed attributes to carry an lname even when occurring + without a namespace. Added new functions attribute*, + unparse-attribute, and macro with-element*, with-namespace* to + the SAX generation wrapper API.</li> + <li>Klacks improvements: Incompatibly changed + klacks:find-element and find-event to consider the current event + as a result. Added klacks-error, klacks:expect, klacks:skip, + klacks:expecting-element. Fixed serialize-event to generate + start-prefix-mapping and end-prefix-mapping events. New function + map-current-namespace-declarations.</li> + <li>fixed build with common-lisp-controller</li> + </ul> + <p class="nomargin"><tt>rel-2007-02-18</tt></p> + <ul class="nomargin"> + <li>New StAX-like parser interface.</li> + <li>Serialization fixes (thanks to Nathan Bird, Donavon Keithley).</li> + <li>characters.lisp cleanup (thanks to Nathan Bird).</li> + <li>Namespace normalizer bugfixes.</li> + <li>Minor changes: clone-node on document as an extension. DOM + class hierarchy reworked. New function parse-empty-document. + Fixed the DOM serializer to not throw away local names. + Fixed a long-standing bug in the parser for documents without a + doctype. ANSI conformance fixes.</li> + </ul> + <p class="nomargin"><tt>rel-2006-01-05</tt></p> + <ul class="nomargin"> + <li>Implemented DOM 2 Core.</li> + <li>Error handling overhaul.</li> + <li>UTF-8 string support in DOM on Lisps without Unicode characters.</li> + <li>Sink API has been changed.</li> + <li>Support internal subset serialization.</li> + <li>Whitespace normalizer.</li> + <li>Gilbert Baumann has clarified the license as Lisp-LGPL.</li> + <li>Use trivial-gray-streams.</li> + </ul> + <p class="nomargin"><tt>rel-2005-06-25</tt></p> + <ul class="nomargin"> + <li>Port to OpenMCL (thanks to Rudi Schlatte).</li> + <li>Port to LispWorks (thanks to Edi Weitz).</li> + <li>Minor new features: <tt>include-default-values</tt> argument to + <tt>make-xmls-builder</tt>; <tt>handler</tt> argument + to <tt>parse-dtd-stream</tt>; SAX proxy class</li> + <li>Various bugfixes.</li> + </ul> + <p class="nomargin"><tt>patch-357</tt> (2004-10-10)</p> + <ul class="nomargin"> + <li>Auto-detect unicode support for better asdf-installability.</li> + <li>Use the puri library for Sys-ID handling.</li> + <li>Semi-automatic caching of DTD instances.</li> + <li>Support user-defined entity resolvers.</li> + <li>Support for Oasis XML Catalogs.</li> + <li>xhtmlgen version of Franz htmlgen.</li> + <li>Fixes for SBCL's unicode support.</li> + </ul> + <p class="nomargin"><tt>patch-306</tt> (2004-09-03)</p> + <ul class="nomargin"> + <li>Event-based serialization which does not require DOM documents</li> + <li>XMLS compatiblity</li> + <li>minor bugfixes (thread safety; should work on clisp again)</li> + </ul> + <p class="nomargin"><tt>patch-279</tt> (2004-05-11)</p> + <ul class="nomargin"> + <li>Validation</li> + <li>bugfixes; XHTML DTD parses again; corrected SAX entity handling</li> + </ul> + <p class="nomargin"><tt>patch-204</tt></p> + <ul class="nomargin"> + <li>Renamed package <tt>XML</tt> to <tt>CXML</tt>.</li> + <li>The unparse functions support non-canonical output now.</li> + </ul> + <p class="nomargin"><tt>patch-191</tt> (2004-03-18)</p> + <ul class="nomargin"> + <li>Initial release.</li> + </ul> +</body> +</html> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/index.xml =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/index.xml 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/index.xml 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,174 @@ +<documentation title="Closure XML"> + <h1>Closure XML Parser</h1> + + <p>An XML parser written in Common Lisp.</p> + + <p> + Closure XML was written + by <a href="http://www.stud.uni-karlsruhe.de/~unk6/">Gilbert + Baumann</a> as part of the Closure web browser and is now + maintained by + <a href="mailto:david@lichteblau.com">David Lichteblau</a>. + It is licensed under Lisp-LGPL. + </p> + + <p> + CXML implements a <a + href="http://www.w3.org/TR/REC-xml-names/">namespace-aware</a>, + validating <a + href="http://www.w3.org/TR/2000/REC-xml-20001006">XML 1.0</a> + parser as well as the <a + href="http://www.w3.org/TR/DOM-Level-2-Core/">DOM Level 2 Core</a> + interfaces. Two parser interfaces are offered, one SAX-like, the + other similar to StAX. + </p> + + <p> + Send bug reports to <a + href="mailto:cxml-devel@common-lisp.net">cxml-devel(a)common-lisp.net</a> + (<a + href="http://common-lisp.net/cgi-bin/mailman/listinfo/cxml-devel">list + information</a>). + </p> + + <h3>Add-on features</h3> + <p> + The following libraries are available as separate downloads: + </p> + <p> + ⬗  + <a href="http://www.lichteblau.com/cxml-rng/">cxml-rng</a> +    + Relax NG validation + </p> + <p> + ⬗  + <a href="http://www.lichteblau.com/cxml-stp/">cxml-stp</a> +    + STP, an alternative to DOM + </p> + + + <a name="changes"/> + <h3>Recent Changes</h3> + <p class="nomargin"><tt>rel-2007-08-05</tt></p> + <ul class="nomargin"> + <li>Various DTD serialization fixes</li> + <li>UTF-8 fix, thanks to Francis Leboutte</li> + </ul> + <p class="nomargin"><tt>rel-2007-07-07</tt></p> + <ul class="nomargin"> + <li> + Fixed build on non-Unicode lisps. Fixed parsing on + non-Unicode lisps. Fixed Unicode detection on OpenMCL. + </li> + <li>New function <tt>cxml:parse</tt>.</li> + <li>Serialization no longer defaults to canonical form.</li> + <li>Fixed octet array argument to make-source.</li> + <li> + XMLS compatibility is not <i>bug-for-bug</i>-compatible with + XMLS any more. There is now a mode using pairs of local name + and namespace URI, and a second mode using qualified names + only. The old behaviour using pairs of prefix and local names + was removed. (Thanks to Douglas Crosher.) + </li> + <li> + SCL support (thanks to Douglas Crosher). Includes support for + implementations where URIs are valid namestrings, and a mode + where normal streams are used instead of xstreams and ystreams + (albeit both SCL-specific at this point). + </li> + <li>new convenience serialization function cxml:doctype. Various + DTD serialization fixes.</li> + </ul> + <p class="nomargin"><tt>rel-2007-05-26</tt></p> + <ul class="nomargin"> + <li>cxml.asd has been split up into <tt>cxml.asd</tt> for the + XML parser and <tt>runes.asd</tt> for the runes package, in + preparation of a complete split of the two systems. Future CXML + releases will use separate tarballs for <tt>runes</tt> + and <tt>cxml</tt>.</li> + <li>xml:base support (SAX and Klacks only, not yet used in DOM). + See documentation <a href="sax.html#saxparser">here</a> and <a + href="klacks.html#locator">here</a>.</li> + <li>New class <tt>broadcast-handler</tt> as a generalization + of the older <tt>sax-proxy</tt>.</li> + <li>New class <tt>tapping-source</tt>, a klacks source that + relays events from an upstream klacks source unchanged, while also + emitting them as SAX events to a user-specified handler at the + same time.</li> + <li>Changed attributes to carry an lname even when occurring + without a namespace. Added new functions attribute*, + unparse-attribute, and macro with-element*, with-namespace* to + the SAX generation wrapper API.</li> + <li>Klacks improvements: Incompatibly changed + klacks:find-element and find-event to consider the current event + as a result. Added klacks-error, klacks:expect, klacks:skip, + klacks:expecting-element. Fixed serialize-event to generate + start-prefix-mapping and end-prefix-mapping events. New function + map-current-namespace-declarations.</li> + <li>fixed build with common-lisp-controller</li> + </ul> + <p class="nomargin"><tt>rel-2007-02-18</tt></p> + <ul class="nomargin"> + <li>New StAX-like parser interface.</li> + <li>Serialization fixes (thanks to Nathan Bird, Donavon Keithley).</li> + <li>characters.lisp cleanup (thanks to Nathan Bird).</li> + <li>Namespace normalizer bugfixes.</li> + <li>Minor changes: clone-node on document as an extension. DOM + class hierarchy reworked. New function parse-empty-document. + Fixed the DOM serializer to not throw away local names. + Fixed a long-standing bug in the parser for documents without a + doctype. ANSI conformance fixes.</li> + </ul> + <p class="nomargin"><tt>rel-2006-01-05</tt></p> + <ul class="nomargin"> + <li>Implemented DOM 2 Core.</li> + <li>Error handling overhaul.</li> + <li>UTF-8 string support in DOM on Lisps without Unicode characters.</li> + <li>Sink API has been changed.</li> + <li>Support internal subset serialization.</li> + <li>Whitespace normalizer.</li> + <li>Gilbert Baumann has clarified the license as Lisp-LGPL.</li> + <li>Use trivial-gray-streams.</li> + </ul> + <p class="nomargin"><tt>rel-2005-06-25</tt></p> + <ul class="nomargin"> + <li>Port to OpenMCL (thanks to Rudi Schlatte).</li> + <li>Port to LispWorks (thanks to Edi Weitz).</li> + <li>Minor new features: <tt>include-default-values</tt> argument to + <tt>make-xmls-builder</tt>; <tt>handler</tt> argument + to <tt>parse-dtd-stream</tt>; SAX proxy class</li> + <li>Various bugfixes.</li> + </ul> + <p class="nomargin"><tt>patch-357</tt> (2004-10-10)</p> + <ul class="nomargin"> + <li>Auto-detect unicode support for better asdf-installability.</li> + <li>Use the puri library for Sys-ID handling.</li> + <li>Semi-automatic caching of DTD instances.</li> + <li>Support user-defined entity resolvers.</li> + <li>Support for Oasis XML Catalogs.</li> + <li>xhtmlgen version of Franz htmlgen.</li> + <li>Fixes for SBCL's unicode support.</li> + </ul> + <p class="nomargin"><tt>patch-306</tt> (2004-09-03)</p> + <ul class="nomargin"> + <li>Event-based serialization which does not require DOM documents</li> + <li>XMLS compatiblity</li> + <li>minor bugfixes (thread safety; should work on clisp again)</li> + </ul> + <p class="nomargin"><tt>patch-279</tt> (2004-05-11)</p> + <ul class="nomargin"> + <li>Validation</li> + <li>bugfixes; XHTML DTD parses again; corrected SAX entity handling</li> + </ul> + <p class="nomargin"><tt>patch-204</tt></p> + <ul class="nomargin"> + <li>Renamed package <tt>XML</tt> to <tt>CXML</tt>.</li> + <li>The unparse functions support non-canonical output now.</li> + </ul> + <p class="nomargin"><tt>patch-191</tt> (2004-03-18)</p> + <ul class="nomargin"> + <li>Initial release.</li> + </ul> +</documentation> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/installation.html =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/installation.html 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/installation.html 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,150 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"> +<html> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> +<title>CXML Installation</title> +<link rel="stylesheet" type="text/css" href="cxml.css"> +</head> +<body> +<div class="sidebar"> +<div class="sidebar-title"><a href="index.html">Closure XML</a></div> +<div class="sidebar-main"><ul class="main"> +<li> +<a href="installation.html">Installing Closure XML</a><ul class="sub"> +<li><a href="installation.html#download"><b>Download</b></a></li> +<li><a href="installation.html#implementations">Implementation-specific notes</a></li> +<li><a href="installation.html#compilation">Compilation</a></li> +<li><a href="installation.html#tests">Tests</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li> +<li> +<a href="sax.html">SAX parsing and serialization</a><ul class="sub"> +<li><a href="sax.html#parser">Parsing and Validating</a></li> +<li><a href="sax.html#serialization">Serialization</a></li> +<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li> +<li><a href="sax.html#rods">Recoders</a></li> +<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li> +<li><a href="sax.html#catalogs">XML Catalogs</a></li> +<li><a href="sax.html#sax">SAX Interface</a></li> +</ul> +</li> +<li> +<a href="klacks.html">Klacks parser</a><ul class="sub"> +<li><a href="klacks.html#sources">Parsing incrementally</a></li> +<li><a href="klacks.html#convenience">Convenience functions</a></li> +<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li> +<li><a href="klacks.html#locator">Location information</a></li> +<li><a href="klacks.html#klacksax">Examples</a></li> +</ul> +</li> +<li> +<a href="dom.html">DOM implementation</a><ul class="sub"> +<li><a href="dom.html#parser">Parsing with the DOM builder</a></li> +<li><a href="dom.html#serialization">Serialization</a></li> +<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li> +</ul></div> +</div> + <h1>Installation of Closure XML</h1> + + <a name="download"></a> + <h2>Download</h2> + <ul> + <li> + <div><a href="http://common-lisp.net/project/cxml/download/">tarballs</a></div> + </li> + <li> + <div> + Anoncvs (<a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/cxml/?cvsroot=cxml">browse</a>): + <pre>cvs -d :pserver:anonymous:anonymous@common-lisp.net:/project/cxml/cvsroot co cxml</pre> + </div> + </li> + </ul> + + <a name="implementations"></a> + <h2>Implementation-specific notes</h2> + <p> + CXML should be portable to all Common Lisp implementations + supported by <a href="http://common-lisp.net/project/cl-plus-ssl/#trivial-gray-streams">trivial-gray-streams</a>. + </p> + <ul> + <li> + The SBCL port uses 16 bit surrogate characters instead of taking + advantage of SBCL's full 21 bit character support. + </li> + </ul> + + <a name="compilation"></a> + <h2>Compilation</h2> + <p> + <a href="http://www.cliki.net/asdf">ASDF</a> is used for + compilation. The following instructions assume that ASDF has + already been loaded. + </p> + + <p> + <b>Prerequisites.</b> + CXML needs the <a href="http://www.cliki.net/Puri">puri</a> library + as well as <a href="http://www.common-lisp.net/project/cl-plus-ssl/#trivial-gray-streams">trivial-gray-streams</a>. + </p> + + <p> + <b>Compiling and loading CXML.</b> + Register the .asd file, e.g. by symlinking it: + </p> + <pre>$ ln -sf `pwd`/cxml.asd /path/to/your/registry/ +$ ln -sf `pwd`/runes.asd /path/to/your/registry/</pre> + <p>Then compile CXML using:</p> + <pre>* (asdf:operate 'asdf:load-op :cxml)</pre> + + <p> + You can then try the <a href="quickstart.html">quick-start example</a>. + </p> + + <a name="tests"></a> + <h2>Tests</h2> + <p>Check out the XML and DOM testsuites:</p> + <pre>$ export CVSROOT=:pserver:anonymous@dev.w3.org:/sources/public +$ cvs login # password is "anonymous" +$ cvs co 2001/XML-Test-Suite/xmlconf +$ cvs co -D '2005-05-06 23:00' 2001/DOM-Test-Suite +$ cd 2001/DOM-Test-Suite && ant dom1-dtd dom2-dtd</pre> + <p> + Omit <tt>-D</tt> to get the latest version, which may not work + with cxml yet. The <tt>ant</tt> step is necessary to run the DOM + tests. + </p> + <p>Usage:</p> + <pre>* (xmlconf:run-all-tests "/path/to/2001/XML-Test-Suite/xmlconf/") +* (domtest:run-all-tests "/path/to/2001/DOM-Test-Suite/") +</pre> + <p> + To compare your results with known output, refer to the files + <tt>XMLCONF</tt> and <tt>DOMTEST</tt> in the cxml distribution. + </p> + + <p> + <i>fixme</i>: Add an explanation of xml/sax-tests here. + </p> + + <p> + <b>fixme</b> domtest.lisp does not understand the current + testsuite driver anymore. To fix this problem, revert the + affected files manually after check-out: + </p> + + <pre>$ cd 2001/XML-Test-Suite/xmlconf/ +xmltest$ patch -p0 -R </path/to/cxml/test/xmlconf-base.diff</pre> + + <p> + The log message for the changes reads "<i>Removed unnecessary + xml:base attribute</i>". If I understand correctly, only + DOM 3 parsers provide the baseURI attribute necessary for + understanding <tt>xmlconf.xml</tt> now. We don't have that + yet. + </p> +</body> +</html> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/installation.xml =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/installation.xml 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/installation.xml 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,101 @@ +<documentation title="CXML Installation"> + <h1>Installation of Closure XML</h1> + + <a name="download"/> + <h2>Download</h2> + <ul> + <li> + <div><a href="http://common-lisp.net/project/cxml/download/">tarballs</a></div> + </li> + <li> + <div> + Anoncvs (<a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/cxml/?cvsroot=cxml">browse</a>): + <pre>cvs -d :pserver:anonymous:anonymous@common-lisp.net:/project/cxml/cvsroot co cxml</pre> + </div> + </li> + </ul> + + <a name="implementations"/> + <h2>Implementation-specific notes</h2> + <p> + CXML should be portable to all Common Lisp implementations + supported by <a + href="http://common-lisp.net/project/cl-plus-ssl/#trivial-gray-streams">trivial-gray-streams</a>. + </p> + <ul> + <li> + The SBCL port uses 16 bit surrogate characters instead of taking + advantage of SBCL's full 21 bit character support. + </li> + </ul> + + <a name="compilation"/> + <h2>Compilation</h2> + <p> + <a href="http://www.cliki.net/asdf">ASDF</a> is used for + compilation. The following instructions assume that ASDF has + already been loaded. + </p> + + <p> + <b>Prerequisites.</b> + CXML needs the <a href="http://www.cliki.net/Puri">puri</a> library + as well as <a href="http://www.common-lisp.net/project/cl-plus-ssl/#trivial-gray-streams">trivial-gray-streams</a>. + </p> + + <p> + <b>Compiling and loading CXML.</b> + Register the .asd file, e.g. by symlinking it: + </p> + <pre>$ ln -sf `pwd`/cxml.asd /path/to/your/registry/ +$ ln -sf `pwd`/runes.asd /path/to/your/registry/</pre> + <p>Then compile CXML using:</p> + <pre>* (asdf:operate 'asdf:load-op :cxml)</pre> + + <p> + You can then try the <a href="quickstart.html">quick-start example</a>. + </p> + + <a name="tests"/> + <h2>Tests</h2> + <p>Check out the XML and DOM testsuites:</p> + <pre>$ export CVSROOT=:pserver:anonymous@dev.w3.org:/sources/public +$ cvs login # password is "anonymous" +$ cvs co 2001/XML-Test-Suite/xmlconf +$ cvs co -D '2005-05-06 23:00' 2001/DOM-Test-Suite +$ cd 2001/DOM-Test-Suite && ant dom1-dtd dom2-dtd</pre> + <p> + Omit <tt>-D</tt> to get the latest version, which may not work + with cxml yet. The <tt>ant</tt> step is necessary to run the DOM + tests. + </p> + <p>Usage:</p> + <pre>* (xmlconf:run-all-tests "/path/to/2001/XML-Test-Suite/xmlconf/") +* (domtest:run-all-tests "/path/to/2001/DOM-Test-Suite/") +</pre> + <p> + To compare your results with known output, refer to the files + <tt>XMLCONF</tt> and <tt>DOMTEST</tt> in the cxml distribution. + </p> + + <p> + <i>fixme</i>: Add an explanation of xml/sax-tests here. + </p> + + <p> + <b>fixme</b> domtest.lisp does not understand the current + testsuite driver anymore.  To fix this problem, revert the + affected files manually after check-out: + </p> + + <pre>$ cd 2001/XML-Test-Suite/xmlconf/ +xmltest$ patch -p0 -R </path/to/cxml/test/xmlconf-base.diff</pre> + + <p> + The log message for the changes reads "<i>Removed unnecessary + xml:base attribute</i>".  If I understand correctly, only + DOM 3 parsers provide the baseURI attribute necessary for + understanding <tt>xmlconf.xml</tt> now.  We don't have that + yet. + </p> +</documentation> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/klacks.html =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/klacks.html 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/klacks.html 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,460 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"> +<html> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> +<title>CXML Klacks parser</title> +<link rel="stylesheet" type="text/css" href="cxml.css"> +</head> +<body> +<div class="sidebar"> +<div class="sidebar-title"><a href="index.html">Closure XML</a></div> +<div class="sidebar-main"><ul class="main"> +<li> +<a href="installation.html">Installing Closure XML</a><ul class="sub"> +<li><a href="installation.html#download"><b>Download</b></a></li> +<li><a href="installation.html#implementations">Implementation-specific notes</a></li> +<li><a href="installation.html#compilation">Compilation</a></li> +<li><a href="installation.html#tests">Tests</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li> +<li> +<a href="sax.html">SAX parsing and serialization</a><ul class="sub"> +<li><a href="sax.html#parser">Parsing and Validating</a></li> +<li><a href="sax.html#serialization">Serialization</a></li> +<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li> +<li><a href="sax.html#rods">Recoders</a></li> +<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li> +<li><a href="sax.html#catalogs">XML Catalogs</a></li> +<li><a href="sax.html#sax">SAX Interface</a></li> +</ul> +</li> +<li> +<a href="klacks.html">Klacks parser</a><ul class="sub"> +<li><a href="klacks.html#sources">Parsing incrementally</a></li> +<li><a href="klacks.html#convenience">Convenience functions</a></li> +<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li> +<li><a href="klacks.html#locator">Location information</a></li> +<li><a href="klacks.html#klacksax">Examples</a></li> +</ul> +</li> +<li> +<a href="dom.html">DOM implementation</a><ul class="sub"> +<li><a href="dom.html#parser">Parsing with the DOM builder</a></li> +<li><a href="dom.html#serialization">Serialization</a></li> +<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li> +</ul></div> +</div> + <h1>Klacks parser</h1> + <p> + The Klacks parser provides an alternative parsing interface, + similar in concept to Java's <a href="http://jcp.org/en/jsr/detail?id=173">Streaming API for + XML</a> (StAX). + </p> + <p> + It implements a streaming, "pull-based" API. This is different + from SAX, which is a "push-based" model. + </p> + <p> + Klacks is implemented using the same code base as the SAX parser + and has the same parsing characteristics (validation, namespace + support, entity resolution) while offering a more flexible interface + than SAX. + </p> + <p> + See below for <a href="#examples">examples</a>. + </p> + + <a name="sources"></a> + <h3>Parsing incrementally using sources</h3> + <p> + To parse using Klacks, create an XML <tt>source</tt> first. + </p> + <p> + <div class="def">Function CXML:MAKE-SOURCE (input &key validate + dtd root entity-resolver disallow-external-subset pathname)</div> + Create and return a source for <tt>input</tt>. + </p> + <p> + Exact behaviour depends on <tt>input</tt>, which can + be one of the following types: + </p> + <ul> + <li> + <tt>pathname</tt> -- a Common Lisp pathname. + Open the file specified by the pathname and create a source for + the resulting stream. See below for information on how to + close the stream. + </li> + <li> +<tt>stream</tt> -- a Common Lisp stream with element-type + <tt>(unsigned-byte 8)</tt>. See below for information on how to + close the stream. + </li> + <li> + <tt>octets</tt> -- an <tt>(unsigned-byte 8)</tt> array. + The array is parsed directly, and interpreted according to the + encoding it specifies. + </li> + <li> + <tt>string</tt>/<tt>rod</tt> -- a rod (or <tt>string</tt> on + unicode-capable implementations). + Parses an XML document from the input string that has already + undergone external-format decoding. + </li> + </ul> + <p> + <b>Closing streams:</b> Sources can refer to Lisp streams that + need to be closed after parsing. This includes a stream passed + explicitly as <tt>input</tt>, a stream created implicitly for the + <tt>pathname</tt> case, as well as any streams created + automatically for external parsed entities referred to by the + document. + </p> + <p> + All these stream get closed automatically if end of file is + reached normally. Use <tt>klacks:close-source</tt> or + <tt>klacks:with-open-source</tt> to ensure that the streams get + closed otherwise. + </p> + <p> + <b>Buffering:</b> By default, the Klacks parser performs buffering + of octets being read from the stream as an optimization. This can + result in unwanted blocking if the stream is a socket and the + parser tries to read more data than required to parse the current + event. Use <tt>:buffering nil</tt> to disable this optimization. + </p> + <ul> + <li> + <tt>buffering</tt> -- Boolean, defaults to <tt>t</tt>. If + enabled, read data several kilobytes at time. If disabled, + read only single bytes at a time. + </li> + </ul> + <p> + The following <b>keyword arguments</b> have the same meaning as + with the SAX parser, please refer to the documentation of <a href="sax.html#parser">parse-file</a> for more information: + </p> + <ul> + <li> + <tt>validate</tt> + </li> + <li> + <tt>dtd</tt> + </li> + <li> +<tt>root</tt> + </li> + <li> + <tt>entity-resolver</tt> + </li> + <li> + <tt>disallow-internal-subset</tt> + </li> + </ul> + <p> + In addition, the following argument is for types of <tt>input</tt> + other than <tt>pathname</tt>: + </p> + <ul> + <li> + <tt>pathname</tt> -- If specified, defines the base URI of the + document based on this pathname instance. + </li> + </ul> + + <p> + Events are read from the stream using the following functions: + </p> + <div class="def">Function KLACKS:PEEK (source)</div> + <p> => :start-document<br> + or => :start-document, version, encoding, standalonep<br> + or => :dtd, name, public-id, system-id<br> + or => :start-element, uri, lname, qname<br> + or => :end-element, uri, lname, qname<br> + or => :characters, data<br> + or => :processing-instruction, target, data<br> + or => :comment, data<br> + or => :end-document, data<br> + or => nil + </p> + <p> + <tt>peek</tt> returns the current event's key and main values. + </p> + <p> + <div class="def">Function KLACKS:PEEK-NEXT (source) => key, value*</div> + </p> + <p> + Advance the source forward to the next event and returns it + like <tt>peek</tt> would. + </p> + <p> + <div class="def">Function KLACKS:PEEK-VALUE (source) => value*</div> + </p> + <p> + Like <tt>peek</tt>, but return only the values, not the key. + </p> + <p> + <div class="def">Function KLACKS:CONSUME (source) => key, value*</div> + </p> + <p> + Return the same values <tt>peek</tt> would, and in addition + advance the source forward to the next event. + </p> + <p> + <div class="def">Function KLACKS:CURRENT-URI (source) => uri</div> + <div class="def">Function KLACKS:CURRENT-LNAME (source) => string</div> + <div class="def">Function KLACKS:CURRENT-QNAME (source) => string</div> + </p> + <p> + If the current event is :start-element or :end-element, return the + corresponding value. Else, signal an error. + </p> + <p> + <div class="def">Function KLACKS:CURRENT-CHARACTERS (source) => string</div> + </p> + <p> + If the current event is :characters, return the character data + value. Else, signal an error. + </p> + <p> + <div class="def">Function KLACKS:CURRENT-CDATA-SECTION-P (source) => boolean</div> + </p> + <p> + If the current event is :characters, determine whether the data was + specified using a CDATA section in the source document. Else, + signal an error. + </p> + <p> + <div class="def">Function KLACKS:MAP-CURRENT-NAMESPACE-DECLARATIONS (fn source) => nil</div> + </p> + <p> + For use only on :start-element and :end-element events, this + function report every namespace declaration on the current element. + On :start-element, these correspond to the xmlns attributes of the + start tag. On :end-element, the declarations of the corresponding + start tag are reported. No inherited namespaces are + included. <tt>fn</tt> is called only for each declaration with two + arguments, the prefix and uri. + </p> + <p> + <div class="def">Function KLACKS:MAP-ATTRIBUTES (fn source)</div> + </p> + <p> + Call <tt>fn</tt> for each attribute of the current start tag in + turn, and pass the following values as arguments to the function: + <ul> + <li>namespace uri</li> + <li>local name</li> + <li>qualified name</li> + <li>attribute value</li> + <li>a boolean indicating whether the attribute was specified + explicitly in the source document, rather than defaulted from + a DTD</li> + </ul> + Only valid for :start-element. + </p> + <p> + Return a list of SAX attribute structures for the current start tag. + Only valid for :start-element. + </p> + + <p> + <div class="def">Function KLACKS:CLOSE-SOURCE (source)</div> + Close all streams referred to by <tt>source</tt>. + </p> + <p> + <div class="def">Macro KLACKS:WITH-OPEN-SOURCE ((var source) &body body)</div> + Evaluate <tt>source</tt> to create a source object, bind it to + symbol <tt>var</tt> and evaluate <tt>body</tt> as an implicit progn. + Call <tt>klacks:close-source</tt> to close the source after + exiting <tt>body</tt>, whether normally or abnormally. + </p> + + <a name="convenience"></a> + <h3>Convenience functions</h3> + <p> + <div class="def">Function KLACKS:FIND-EVENT (source key)</div> + Read events from <tt>source</tt> and discard them until an event + of type <i>key</i> is found. Return values like <tt>peek</tt>, or + NIL if no such event was found. + </p> + <p> + <div class="def">Function KLACKS:FIND-ELEMENT (source &optional + lname uri)</div> + Read events from <tt>source</tt> and discard them until an event + of type :start-element is found with matching local name and + namespace uri is found. If <tt>lname</tt> is <tt>nil</tt>, any + tag name matches. If <tt>uri</tt> is <tt>nil</tt>, any + namespace matches. Return values like <tt>peek</tt> or NIL if no + such event was found. + </p> + <p> + <div class="def">Condition KLACKS:KLACKS-ERROR (xml-parse-error)</div> + The condition class signalled by <tt>expect</tt>. + </p> + <p> + <div class="def">Function KLACKS:EXPECT (source key &optional + value1 value2 value3)</div> + Assert that the current event is equal to (key value1 value2 + value3). (Ignore <i>value</i> arguments that are NIL.) If so, + return it as multiple values. Otherwise signal a + <tt>klacks-error</tt>. + </p> + <p> + <div class="def">Function KLACKS:SKIP (source key &optional + value1 value2 value3)</div> + <tt>expect</tt> the specific event, then <tt>consume</tt> it. + </p> + <p> + <div class="def">Macro KLACKS:EXPECTING-ELEMENT ((fn source + &optional lname uri) &body body</div> + Assert that the current event matches (:start-element uri lname). + (Ignore <i>value</i> arguments that are NIL) Otherwise signal a + <tt>klacks-error</tt>. + Evaluate <tt>body</tt> as an implicit progn. Finally assert that + the remaining event matches (:end-element uri lname). + </p> + + <a name="klacksax"></a> + <h3>Bridging Klacks and SAX</h3> + <p> + <div class="def">Function KLACKS:SERIALIZE-EVENT (source handler)</div> + Send the current klacks event from <tt>source</tt> as a SAX + event to the SAX <tt>handler</tt> and consume it. + </p> + <p> + <div class="def">Function KLACKS:SERIALIZE-ELEMENT (source handler + &key document-events)</div> + Read all klacks events from the following <tt>:start-element</tt> to + its <tt>:end-element</tt> and send them as SAX events + to <tt>handler</tt>. When this function is called, the current + event must be <tt>:start-element</tt>, else an error is + signalled. With <tt>document-events</tt> (the default), + <tt>sax:start-document</tt> and <tt>sax:end-document</tt> events + are sent around the element. + </p> + <p> + <div class="def">Function KLACKS:SERIALIZE-SOURCE (source handler)</div> + Read all klacks events from <tt>source</tt> and send them as SAX + events to the SAX <tt>handler</tt>. + </p> + <p> + <div class="def">Class KLACKS:TAPPING-SOURCE (source)</div> + A klacks source that relays events from an upstream klacks source + unchanged, while also emitting them as SAX events to a + user-specified handler at the same time. + </p> + <p> + <div class="def">Functon KLACKS:MAKE-TAPPING-SOURCE + (upstream-source &optional sax-handler)</div> + Create a tapping source relaying events + for <tt>upstream-source</tt>, and sending SAX events + to <tt>sax-handler</tt>. + </p> + + <a name="locator"></a> + <h3>Location information</h3> + <p> + <div class="def">Function KLACKS:CURRENT-LINE-NUMBER (source)</div> + Return an approximation of the current line number, or NIL. + </p> + <p> + <div class="def">Function KLACKS:CURRENT-COLUMN-NUMBER (source)</div> + Return an approximation of the current column number, or NIL. + </p> + <p> + <div class="def">Function KLACKS:CURRENT-SYSTEM-ID (source)</div> + Return the URI of the document being parsed. This is either the + main document, or the entity's system ID while contents of a parsed + general external entity are being processed. + </p> + <p> + <div class="def">Function KLACKS:CURRENT-XML-BASE (source)</div> + Return the [Base URI] of the current element. This URI can differ from + the value returned by <tt>current-system-id</tt> if xml:base + attributes are present. + </p> + + <a name="examples"></a> + <h3>Examples</h3> + <p> + The following example illustrates creation of a klacks <tt>source</tt>, + use of the <tt>peek-next</tt> function to read individual events, + and shows some of the most common event types. + </p> + <pre>* <b>(defparameter *source* (cxml:make-source "<example>text</example>"))</b> +*SOURCE* + +* <b>(klacks:peek-next *source*)</b> +:START-DOCUMENT + +* <b>(klacks:peek-next *source*)</b> +:START-ELEMENT +NIL ;namespace URI +"example" ;local name +"example" ;qualified name + +* <b>(klacks:peek-next *source*)</b> +:CHARACTERS +"text" + +* <b>(klacks:peek-next *source*)</b> +:END-ELEMENT +NIL +"example" +"example" + +* <b>(klacks:peek-next *source*)</b> +:END-DOCUMENT + +* <b>(klacks:peek-next *source*)</b> +NIL</pre> + + <p> + In this example, <tt>find-element</tt> is used to skip over the + uninteresting events until the opening <tt>child1</tt> tag is + found. Then <tt>serialize-element</tt> is used to generate SAX + events for the following element, including its children, and an + xmls-compatible list structure is built from those + events. <tt>find-element</tt> skips over whitespace, + and <tt>find-event</tt> is used to parse up + to <tt>:end-document</tt>, ensuring that the source has been + closed. + </p> + <pre>* <b>(defparameter *source* + (cxml:make-source "<example> + <child1><p>foo</p></child1> + <child2 bar='baz'/> + </example>"))</b> +*SOURCE* + +* <b>(klacks:find-element *source* "child1")</b> +:START-ELEMENT +NIL +"child1" +"child1" + +* <b>(klacks:serialize-element *source* (cxml-xmls:make-xmls-builder))</b> +("child1" NIL ("p" NIL "foo")) + +* <b>(klacks:find-element *source*)</b> +:START-ELEMENT +NIL +"child2" +"child2" + +* <b>(klacks:serialize-element *source* (cxml-xmls:make-xmls-builder))</b> +("child2" (("bar" "baz"))) + +* <b>(klacks:find-event *source* :end-document)</b> +:END-DOCUMENT +NIL +NIL +NIL +</pre> +</body> +</html> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/klacks.xml =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/klacks.xml 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/klacks.xml 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,410 @@ +<documentation title="CXML Klacks parser"> + <h1>Klacks parser</h1> + <p> + The Klacks parser provides an alternative parsing interface, + similar in concept to Java's <a + href="http://jcp.org/en/jsr/detail?id=173">Streaming API for + XML</a> (StAX). + </p> + <p> + It implements a streaming, "pull-based" API. This is different + from SAX, which is a "push-based" model. + </p> + <p> + Klacks is implemented using the same code base as the SAX parser + and has the same parsing characteristics (validation, namespace + support, entity resolution) while offering a more flexible interface + than SAX. + </p> + <p> + See below for <a href="#examples">examples</a>. + </p> + + <a name="sources"/> + <h3>Parsing incrementally using sources</h3> + <p> + To parse using Klacks, create an XML <tt>source</tt> first. + </p> + <p> + <div class="def">Function CXML:MAKE-SOURCE (input &key validate + dtd root entity-resolver disallow-external-subset pathname)</div> + Create and return a source for <tt>input</tt>. + </p> + <p> + Exact behaviour depends on <tt>input</tt>, which can + be one of the following types: + </p> + <ul> + <li> + <tt>pathname</tt> -- a Common Lisp pathname. + Open the file specified by the pathname and create a source for + the resulting stream. See below for information on how to + close the stream. + </li> + <li><tt>stream</tt> -- a Common Lisp stream with element-type + <tt>(unsigned-byte 8)</tt>. See below for information on how to + close the stream. + </li> + <li> + <tt>octets</tt> -- an <tt>(unsigned-byte 8)</tt> array. + The array is parsed directly, and interpreted according to the + encoding it specifies. + </li> + <li> + <tt>string</tt>/<tt>rod</tt> -- a rod (or <tt>string</tt> on + unicode-capable implementations). + Parses an XML document from the input string that has already + undergone external-format decoding. + </li> + </ul> + <p> + <b>Closing streams:</b> Sources can refer to Lisp streams that + need to be closed after parsing. This includes a stream passed + explicitly as <tt>input</tt>, a stream created implicitly for the + <tt>pathname</tt> case, as well as any streams created + automatically for external parsed entities referred to by the + document. + </p> + <p> + All these stream get closed automatically if end of file is + reached normally. Use <tt>klacks:close-source</tt> or + <tt>klacks:with-open-source</tt> to ensure that the streams get + closed otherwise. + </p> + <p> + <b>Buffering:</b> By default, the Klacks parser performs buffering + of octets being read from the stream as an optimization. This can + result in unwanted blocking if the stream is a socket and the + parser tries to read more data than required to parse the current + event. Use <tt>:buffering nil</tt> to disable this optimization. + </p> + <ul> + <li> + <tt>buffering</tt> -- Boolean, defaults to <tt>t</tt>. If + enabled, read data several kilobytes at time. If disabled, + read only single bytes at a time. + </li> + </ul> + <p> + The following <b>keyword arguments</b> have the same meaning as + with the SAX parser, please refer to the documentation of <a + href="sax.html#parser">parse-file</a> for more information: + </p> + <ul> + <li> + <tt>validate</tt> + </li> + <li> + <tt>dtd</tt> + </li> + <li><tt>root</tt> + </li> + <li> + <tt>entity-resolver</tt> + </li> + <li> + <tt>disallow-internal-subset</tt> + </li> + </ul> + <p> + In addition, the following argument is for types of <tt>input</tt> + other than <tt>pathname</tt>: + </p> + <ul> + <li> + <tt>pathname</tt> -- If specified, defines the base URI of the + document based on this pathname instance. + </li> + </ul> + + <p> + Events are read from the stream using the following functions: + </p> + <div class="def">Function KLACKS:PEEK (source)</div> + <p> => :start-document<br/> + or => :start-document, version, encoding, standalonep<br/> + or => :dtd, name, public-id, system-id<br/> + or => :start-element, uri, lname, qname<br/> + or => :end-element, uri, lname, qname<br/> + or => :characters, data<br/> + or => :processing-instruction, target, data<br/> + or => :comment, data<br/> + or => :end-document, data<br/> + or => nil + </p> + <p> + <tt>peek</tt> returns the current event's key and main values. + </p> + <p> + <div class="def">Function KLACKS:PEEK-NEXT (source) => key, value*</div> + </p> + <p> + Advance the source forward to the next event and returns it + like <tt>peek</tt> would. + </p> + <p> + <div class="def">Function KLACKS:PEEK-VALUE (source) => value*</div> + </p> + <p> + Like <tt>peek</tt>, but return only the values, not the key. + </p> + <p> + <div class="def">Function KLACKS:CONSUME (source) => key, value*</div> + </p> + <p> + Return the same values <tt>peek</tt> would, and in addition + advance the source forward to the next event. + </p> + <p> + <div class="def">Function KLACKS:CURRENT-URI (source) => uri</div> + <div class="def">Function KLACKS:CURRENT-LNAME (source) => string</div> + <div class="def">Function KLACKS:CURRENT-QNAME (source) => string</div> + </p> + <p> + If the current event is :start-element or :end-element, return the + corresponding value. Else, signal an error. + </p> + <p> + <div class="def">Function KLACKS:CURRENT-CHARACTERS (source) => string</div> + </p> + <p> + If the current event is :characters, return the character data + value. Else, signal an error. + </p> + <p> + <div class="def">Function KLACKS:CURRENT-CDATA-SECTION-P (source) => boolean</div> + </p> + <p> + If the current event is :characters, determine whether the data was + specified using a CDATA section in the source document. Else, + signal an error. + </p> + <p> + <div class="def">Function KLACKS:MAP-CURRENT-NAMESPACE-DECLARATIONS (fn source) => nil</div> + </p> + <p> + For use only on :start-element and :end-element events, this + function report every namespace declaration on the current element. + On :start-element, these correspond to the xmlns attributes of the + start tag. On :end-element, the declarations of the corresponding + start tag are reported. No inherited namespaces are + included. <tt>fn</tt> is called only for each declaration with two + arguments, the prefix and uri. + </p> + <p> + <div class="def">Function KLACKS:MAP-ATTRIBUTES (fn source)</div> + </p> + <p> + Call <tt>fn</tt> for each attribute of the current start tag in + turn, and pass the following values as arguments to the function: + <ul> + <li>namespace uri</li> + <li>local name</li> + <li>qualified name</li> + <li>attribute value</li> + <li>a boolean indicating whether the attribute was specified + explicitly in the source document, rather than defaulted from + a DTD</li> + </ul> + Only valid for :start-element. + </p> + <p> + Return a list of SAX attribute structures for the current start tag. + Only valid for :start-element. + </p> + + <p> + <div class="def">Function KLACKS:CLOSE-SOURCE (source)</div> + Close all streams referred to by <tt>source</tt>. + </p> + <p> + <div class="def">Macro KLACKS:WITH-OPEN-SOURCE ((var source) &body body)</div> + Evaluate <tt>source</tt> to create a source object, bind it to + symbol <tt>var</tt> and evaluate <tt>body</tt> as an implicit progn. + Call <tt>klacks:close-source</tt> to close the source after + exiting <tt>body</tt>, whether normally or abnormally. + </p> + + <a name="convenience"/> + <h3>Convenience functions</h3> + <p> + <div class="def">Function KLACKS:FIND-EVENT (source key)</div> + Read events from <tt>source</tt> and discard them until an event + of type <i>key</i> is found. Return values like <tt>peek</tt>, or + NIL if no such event was found. + </p> + <p> + <div class="def">Function KLACKS:FIND-ELEMENT (source &optional + lname uri)</div> + Read events from <tt>source</tt> and discard them until an event + of type :start-element is found with matching local name and + namespace uri is found. If <tt>lname</tt> is <tt>nil</tt>, any + tag name matches. If <tt>uri</tt> is <tt>nil</tt>, any + namespace matches. Return values like <tt>peek</tt> or NIL if no + such event was found. + </p> + <p> + <div class="def">Condition KLACKS:KLACKS-ERROR (xml-parse-error)</div> + The condition class signalled by <tt>expect</tt>. + </p> + <p> + <div class="def">Function KLACKS:EXPECT (source key &optional + value1 value2 value3)</div> + Assert that the current event is equal to (key value1 value2 + value3). (Ignore <i>value</i> arguments that are NIL.) If so, + return it as multiple values. Otherwise signal a + <tt>klacks-error</tt>. + </p> + <p> + <div class="def">Function KLACKS:SKIP (source key &optional + value1 value2 value3)</div> + <tt>expect</tt> the specific event, then <tt>consume</tt> it. + </p> + <p> + <div class="def">Macro KLACKS:EXPECTING-ELEMENT ((fn source + &optional lname uri) &body body</div> + Assert that the current event matches (:start-element uri lname). + (Ignore <i>value</i> arguments that are NIL) Otherwise signal a + <tt>klacks-error</tt>. + Evaluate <tt>body</tt> as an implicit progn. Finally assert that + the remaining event matches (:end-element uri lname). + </p> + + <a name="klacksax"/> + <h3>Bridging Klacks and SAX</h3> + <p> + <div class="def">Function KLACKS:SERIALIZE-EVENT (source handler)</div> + Send the current klacks event from <tt>source</tt> as a SAX + event to the SAX <tt>handler</tt> and consume it. + </p> + <p> + <div class="def">Function KLACKS:SERIALIZE-ELEMENT (source handler + &key document-events)</div> + Read all klacks events from the following <tt>:start-element</tt> to + its <tt>:end-element</tt> and send them as SAX events + to <tt>handler</tt>. When this function is called, the current + event must be <tt>:start-element</tt>, else an error is + signalled. With <tt>document-events</tt> (the default), + <tt>sax:start-document</tt> and <tt>sax:end-document</tt> events + are sent around the element. + </p> + <p> + <div class="def">Function KLACKS:SERIALIZE-SOURCE (source handler)</div> + Read all klacks events from <tt>source</tt> and send them as SAX + events to the SAX <tt>handler</tt>. + </p> + <p> + <div class="def">Class KLACKS:TAPPING-SOURCE (source)</div> + A klacks source that relays events from an upstream klacks source + unchanged, while also emitting them as SAX events to a + user-specified handler at the same time. + </p> + <p> + <div class="def">Functon KLACKS:MAKE-TAPPING-SOURCE + (upstream-source &optional sax-handler)</div> + Create a tapping source relaying events + for <tt>upstream-source</tt>, and sending SAX events + to <tt>sax-handler</tt>. + </p> + + <a name="locator"/> + <h3>Location information</h3> + <p> + <div class="def">Function KLACKS:CURRENT-LINE-NUMBER (source)</div> + Return an approximation of the current line number, or NIL. + </p> + <p> + <div class="def">Function KLACKS:CURRENT-COLUMN-NUMBER (source)</div> + Return an approximation of the current column number, or NIL. + </p> + <p> + <div class="def">Function KLACKS:CURRENT-SYSTEM-ID (source)</div> + Return the URI of the document being parsed. This is either the + main document, or the entity's system ID while contents of a parsed + general external entity are being processed. + </p> + <p> + <div class="def">Function KLACKS:CURRENT-XML-BASE (source)</div> + Return the [Base URI] of the current element. This URI can differ from + the value returned by <tt>current-system-id</tt> if xml:base + attributes are present. + </p> + + <a name="examples"/> + <h3>Examples</h3> + <p> + The following example illustrates creation of a klacks <tt>source</tt>, + use of the <tt>peek-next</tt> function to read individual events, + and shows some of the most common event types. + </p> + <pre>* <b>(defparameter *source* (cxml:make-source "<example>text</example>"))</b> +*SOURCE* + +* <b>(klacks:peek-next *source*)</b> +:START-DOCUMENT + +* <b>(klacks:peek-next *source*)</b> +:START-ELEMENT +NIL ;namespace URI +"example" ;local name +"example" ;qualified name + +* <b>(klacks:peek-next *source*)</b> +:CHARACTERS +"text" + +* <b>(klacks:peek-next *source*)</b> +:END-ELEMENT +NIL +"example" +"example" + +* <b>(klacks:peek-next *source*)</b> +:END-DOCUMENT + +* <b>(klacks:peek-next *source*)</b> +NIL</pre> + + <p> + In this example, <tt>find-element</tt> is used to skip over the + uninteresting events until the opening <tt>child1</tt> tag is + found. Then <tt>serialize-element</tt> is used to generate SAX + events for the following element, including its children, and an + xmls-compatible list structure is built from those + events. <tt>find-element</tt> skips over whitespace, + and <tt>find-event</tt> is used to parse up + to <tt>:end-document</tt>, ensuring that the source has been + closed. + </p> + <pre>* <b>(defparameter *source* + (cxml:make-source "<example> + <child1><p>foo</p></child1> + <child2 bar='baz'/> + </example>"))</b> +*SOURCE* + +* <b>(klacks:find-element *source* "child1")</b> +:START-ELEMENT +NIL +"child1" +"child1" + +* <b>(klacks:serialize-element *source* (cxml-xmls:make-xmls-builder))</b> +("child1" NIL ("p" NIL "foo")) + +* <b>(klacks:find-element *source*)</b> +:START-ELEMENT +NIL +"child2" +"child2" + +* <b>(klacks:serialize-element *source* (cxml-xmls:make-xmls-builder))</b> +("child2" (("bar" "baz"))) + +* <b>(klacks:find-event *source* :end-document)</b> +:END-DOCUMENT +NIL +NIL +NIL +</pre> +</documentation> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/quickstart.html =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/quickstart.html 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/quickstart.html 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,312 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"> +<html> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> +<title>CXML Quick-Start Example</title> +<link rel="stylesheet" type="text/css" href="cxml.css"> +</head> +<body> +<div class="sidebar"> +<div class="sidebar-title"><a href="index.html">Closure XML</a></div> +<div class="sidebar-main"><ul class="main"> +<li> +<a href="installation.html">Installing Closure XML</a><ul class="sub"> +<li><a href="installation.html#download"><b>Download</b></a></li> +<li><a href="installation.html#implementations">Implementation-specific notes</a></li> +<li><a href="installation.html#compilation">Compilation</a></li> +<li><a href="installation.html#tests">Tests</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li> +<li> +<a href="sax.html">SAX parsing and serialization</a><ul class="sub"> +<li><a href="sax.html#parser">Parsing and Validating</a></li> +<li><a href="sax.html#serialization">Serialization</a></li> +<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li> +<li><a href="sax.html#rods">Recoders</a></li> +<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li> +<li><a href="sax.html#catalogs">XML Catalogs</a></li> +<li><a href="sax.html#sax">SAX Interface</a></li> +</ul> +</li> +<li> +<a href="klacks.html">Klacks parser</a><ul class="sub"> +<li><a href="klacks.html#sources">Parsing incrementally</a></li> +<li><a href="klacks.html#convenience">Convenience functions</a></li> +<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li> +<li><a href="klacks.html#locator">Location information</a></li> +<li><a href="klacks.html#klacksax">Examples</a></li> +</ul> +</li> +<li> +<a href="dom.html">DOM implementation</a><ul class="sub"> +<li><a href="dom.html#parser">Parsing with the DOM builder</a></li> +<li><a href="dom.html#serialization">Serialization</a></li> +<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li> +</ul></div> +</div> + <h1>Quick-Start Example / FAQ</h1> + + <p> + Make sure to <a href="installation.html#installation">install and load</a> cxml first. + </p> + + <h3> + On this page + </h3> + <ul> +<li><a href="#id44301"><heading>Parsing a file</heading></a></li> +<li><a href="#id45340"><heading>Using DOM</heading></a></li> +<li><a href="#id45373"><heading>Serializing DOM</heading></a></li> +<li><a href="#id45393"><heading>Parsing into XMLS-like lists</heading></a></li> +<li><a href="#id45437"><heading>Parsing incrementally using Klacks</heading></a></li> +<li><a href="#id45471"><heading>Writing XML</heading></a></li> +<li><a href="#id45496"><heading>Help! CXML says 'URI scheme :HTTP not supported'</heading></a></li> +<li><a href="#id45563"><heading>Loading DTDs from local files</heading></a></li> +<li><a href="#id45589"><heading>Can I skip loading of DTDs entirely?</heading></a></li> +<li><a href="#id45625"><heading> + Catalogs: How can I use the HTML DTD installed by my distribution? + </heading></a></li> +<li><a href="#id45651"><heading> + Can I load DTDs through HTTP? + </heading></a></li> +</ul> + + <p> + To try the following examples, create a test file + called <tt>example.xml</tt>: + </p> + <pre>* <b>(with-open-file (s "example.xml" :direction :output) + (write-string "<test a='b'><child/></test>" s))</b></pre> + + <a name="id44301"></a><h3><heading>Parsing a file</heading></h3> + + <p>Parse <tt>example.xml</tt> into a DOM tree (<a href="sax.html#parser">read + more</a>):</p> + <pre>* <b>(cxml:parse-file "example.xml" (cxml-dom:make-dom-builder))</b> +#<DOM-IMPL::DOCUMENT @ #x72206172> + +;; save result for later: +* <b>(defparameter *example* *)</b> +*EXAMPLE*</pre> + + <a name="id45340"></a><h3><heading>Using DOM</heading></h3> + + <p>Inspect the DOM tree (<a href="sax.html#dom">read more</a>):</p> + <pre>* <b>(dom:document-element *example*)</b> +#<DOM-IMPL::ELEMENT test @ #x722b6ba2> + +* (<b>dom:tag-name</b> (dom:document-element *example*)) +"test" + +* (<b>dom:child-nodes</b> (dom:document-element *example*)) +#(#<DOM-IMPL::ELEMENT child @ #x722b6d8a>) + +* (<b>dom:get-attribute</b> (dom:document-element *example*) <b>"a"</b>) +"b"</pre> + + <a name="id45373"></a><h3><heading>Serializing DOM</heading></h3> + + <p>Serialize the DOM document back into a file (<a href="sax.html#serialization">read more</a>):</p> + <pre>(with-open-file (out "example.out" :direction :output :element-type '(unsigned-byte 8)) + <b>(dom:map-document (cxml:make-octet-stream-sink out) *example*)</b></pre> + + <a name="id45393"></a><h3><heading>Parsing into XMLS-like lists</heading></h3> + + <p> + If DOM is not the representation you want to you, parsing into + other data structures is possible using the same SAX parser + function, while using a different handler. + The XMLS builder is included for compatibility with XMLS, and also + also sample code (see cxml/xml/xmls-compat.lisp) for your own + handlers. + </p> + + <p>As an alternative to DOM, parse into xmls-compatible list + structure (<a href="xmls-compat.html">read more</a>):</p> + <pre>* <b>(cxml:parse-file "example.xml" (cxml-xmls:make-xmls-builder))</b> +("test" (("a" "b")) ("child" NIL))</pre> + + <p> + Again, serialization into XML is done using a sink as a SAX + handler and a data-structure specific function to generate SAX + events for the document, in this case <tt>cxml-xmls:map-node</tt>. + </p> + + <pre>* (with-open-file (out "example.out" :direction :output :element-type '(unsigned-byte 8)) + (<b>cxml-xmls:map-node (cxml:make-octet-stream-sink out) + '("test" (("a" "b")) ("child" nil)))</b>)</pre> + + <a name="id45437"></a><h3><heading>Parsing incrementally using Klacks</heading></h3> + + <p>Use klacks to read events from the parser incrementally. The + following example looks only for :start-element and :end-element + events and prints them (<a href="klacks.html">read more</a>):</p> + <pre>* <b>(klacks:with-open-source + (s (cxml:make-source #p"example.xml"))</b> + (loop + for key = <b>(klacks:peek s)</b> + while key + do + (case key + (:start-element + (format t "~A {" <b>(klacks:current-qname s)</b>)) + (:end-element + (format t "}"))) + <b>(klacks:consume s)</b>)) +test {child {}}</pre> + + <a name="id45471"></a><h3><heading>Writing XML</heading></h3> + + <p> + Serialization is always done using sinks, which accept SAX events, + but there are convenience functions and macros to make that easier + to use: + </p> + <pre>(cxml:with-xml-output (cxml:make-octet-stream-sink stream :indentation 2 :canonical nil) + (cxml:with-element "foo" + (cxml:attribute "xyz" "abc") + (cxml:with-element "bar" + (cxml:attribute "blub" "bla")) + (cxml:text "Hi there.")))</pre> + <p> + Prints this to <tt>stream</tt>: + </p> + <pre><foo xyz="abc"> + <bar blub="bla"></bar> + Hi there. +</foo></pre> + + <a name="id45496"></a><h3><heading>Help! CXML says 'URI scheme :HTTP not supported'</heading></h3> + + <p> + By default, this error will occur when the DTD (or generally, any + entity) has an http:// URL as its system ID. CXML itself + understands only file:// URLs, but allows users to customize the + behaviour for all URLs. + </p> + + <p> + The are several solutions to this, covered in detail below: + <ul> + <li> + Load the DTD/entity from local files using an entity resolver + </li> + <li> + Skip parsing of the DTD/entity entirely by pretending it is + empty, again using an entity resolver. + </li> + <li> + Use a <em>catalog</em> to make CXML find DTDs in the local + filesystem automatically. + </li> + <li> + Teach CXML actually load DTDs using HTTP. + </li> + </ul> + </p> + + <p> + Here are the example files for the following solutions to this + problem: + </p> + + <a href="http://www.lichteblau.com/blubba/dtdexample.xml"> + <tt>dtdexample.xml</tt>:</a> + <pre><!DOCTYPE test SYSTEM 'http://www.lichteblau.com/blubba/dtdexample.dtd'> +<test a='b'>blub<child/></test></pre> + + <a href="http://www.lichteblau.com/blubba/dtdexample.dtd"> + <tt>dtdexample.dtd</tt></a>: + <pre><!ELEMENT test (#PCDATA|child)*> +<!ATTLIST test + a CDATA #REQUIRED + > + +<!ELEMENT child EMPTY> +</pre> + + <a name="id45563"></a><h3><heading>Loading DTDs from local files</heading></h3> + + <p> + Use the :entity-resolver argument to <tt>parse-file</tt> to + specify a function that maps System IDs and Public IDs to local + files of your choice: + </p> + + <pre>(let ((uri "http://www.lichteblau.com/blubba/dtdexample.dtd") + (pathname "dtdexample.dtd")) + (flet ((resolver (pubid sysid) + (declare (ignore pubid)) + <b>(when (puri:uri= sysid (puri:parse-uri uri)) + (open pathname :element-type '(unsigned-byte 8)))</b>)) + (cxml:parse-file "dtdexample.xml" (cxml-dom:make-dom-builder) <b>:entity-resolver #'resolver</b>)))</pre> + + + <a name="id45589"></a><h3><heading>Can I skip loading of DTDs entirely?</heading></h3> + + <p> + Yes and no. + </p> + <p> + <i>Yes</i>, you can force CXML to do this, see the following example. + </p> + + <p> + But no, skipping the DTD will not actually work if the document + references entities declared in the DTD, especially since neither + SAX nor DOM are able to report unresolved entity references in + attributes. + </p> + + <p> + The trick to make CXML skip the DTD is to pretend that it is empty + by returning a zero-length stream instead: + </p> + + <pre>(flet ((resolver (pubid sysid) + (declare (ignore pubid sysid)) + <b>(flexi-streams:make-in-memory-input-stream nil)</b>)) + (cxml:parse-file "dtdexample.xml" (cxml-dom:make-dom-builder) <b>:entity-resolver #'resolver</b>))</pre> + + <a name="id45625"></a><h3><heading> + Catalogs: How can I use the HTML DTD installed by my distribution? + </heading></h3> + + <p> + Rather than writing an entity resolver function yourself, CXML can + use XML catalogs to find DTDs and entity files on your local system. + </p> + <p> + Catalogs are particularly helpful for DTDs that are + pre-installed. For example, most Linux distributions include a + package for the XHTML DTD. The DTD will reside in a + distribution-dependent location, which the central catalog file + points to. + </p> + <p>By default, CXML looks for the catalog in /etc/xml/catalog + (Linux) and /usr/local/share/xml/catalog.ports (FreeBSD). + </p> + <pre>* <b>(setf cxml:*catalog* (cxml:make-catalog))</b> +* (cxml:parse-file "test.xhtml" (cxml-dom:make-dom-builder))</pre> + + <a name="id45651"></a><h3><heading> + Can I load DTDs through HTTP? + </heading></h3> + + <p> + Sure, just use an entity-resolver function that does it. + </p> + <p> + Install <a href="http://weitz.de/drakma/">Drakma</a> and try this: + </p> + <pre>(flet ((resolver (pubid sysid) + (declare (ignore pubid)) + <b>(when (eq (puri:uri-scheme sysid) :http) + (drakma:http-request sysid :want-stream t))</b>)) + (cxml:parse-file "dtdexample.xml" (cxml-dom:make-dom-builder) <b>:entity-resolver #'resolver</b>))</pre> +</body> +</html> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/quickstart.xml =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/quickstart.xml 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/quickstart.xml 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,247 @@ +<documentation title="CXML Quick-Start Example"> + <h1>Quick-Start Example / FAQ</h1> + + <p> + Make sure to <a href="installation.html#installation">install and load</a> cxml first. + </p> + + <h3> + On this page + </h3> + <page-index/> + + <p> + To try the following examples, create a test file + called <tt>example.xml</tt>: + </p> + <pre>* <b>(with-open-file (s "example.xml" :direction :output) + (write-string "<test a='b'><child/></test>" s))</b></pre> + + <heading>Parsing a file</heading> + + <p>Parse <tt>example.xml</tt> into a DOM tree (<a href="sax.html#parser">read + more</a>):</p> + <pre>* <b>(cxml:parse-file "example.xml" (cxml-dom:make-dom-builder))</b> +#<DOM-IMPL::DOCUMENT @ #x72206172> + +;; save result for later: +* <b>(defparameter *example* *)</b> +*EXAMPLE*</pre> + + <heading>Using DOM</heading> + + <p>Inspect the DOM tree (<a href="sax.html#dom">read more</a>):</p> + <pre>* <b>(dom:document-element *example*)</b> +#<DOM-IMPL::ELEMENT test @ #x722b6ba2> + +* (<b>dom:tag-name</b> (dom:document-element *example*)) +"test" + +* (<b>dom:child-nodes</b> (dom:document-element *example*)) +#(#<DOM-IMPL::ELEMENT child @ #x722b6d8a>) + +* (<b>dom:get-attribute</b> (dom:document-element *example*) <b>"a"</b>) +"b"</pre> + + <heading>Serializing DOM</heading> + + <p>Serialize the DOM document back into a file (<a + href="sax.html#serialization">read more</a>):</p> + <pre>(with-open-file (out "example.out" :direction :output :element-type '(unsigned-byte 8)) + <b>(dom:map-document (cxml:make-octet-stream-sink out) *example*)</b></pre> + + <heading>Parsing into XMLS-like lists</heading> + + <p> + If DOM is not the representation you want to you, parsing into + other data structures is possible using the same SAX parser + function, while using a different handler. + The XMLS builder is included for compatibility with XMLS, and also + also sample code (see cxml/xml/xmls-compat.lisp) for your own + handlers. + </p> + + <p>As an alternative to DOM, parse into xmls-compatible list + structure (<a href="xmls-compat.html">read more</a>):</p> + <pre>* <b>(cxml:parse-file "example.xml" (cxml-xmls:make-xmls-builder))</b> +("test" (("a" "b")) ("child" NIL))</pre> + + <p> + Again, serialization into XML is done using a sink as a SAX + handler and a data-structure specific function to generate SAX + events for the document, in this case <tt>cxml-xmls:map-node</tt>. + </p> + + <pre>* (with-open-file (out "example.out" :direction :output :element-type '(unsigned-byte 8)) + (<b>cxml-xmls:map-node (cxml:make-octet-stream-sink out) + '("test" (("a" "b")) ("child" nil)))</b>)</pre> + + <heading>Parsing incrementally using Klacks</heading> + + <p>Use klacks to read events from the parser incrementally. The + following example looks only for :start-element and :end-element + events and prints them (<a href="klacks.html">read more</a>):</p> + <pre>* <b>(klacks:with-open-source + (s (cxml:make-source #p"example.xml"))</b> + (loop + for key = <b>(klacks:peek s)</b> + while key + do + (case key + (:start-element + (format t "~A {" <b>(klacks:current-qname s)</b>)) + (:end-element + (format t "}"))) + <b>(klacks:consume s)</b>)) +test {child {}}</pre> + + <heading>Writing XML</heading> + + <p> + Serialization is always done using sinks, which accept SAX events, + but there are convenience functions and macros to make that easier + to use: + </p> + <pre>(cxml:with-xml-output (cxml:make-octet-stream-sink stream :indentation 2 :canonical nil) + (cxml:with-element "foo" + (cxml:attribute "xyz" "abc") + (cxml:with-element "bar" + (cxml:attribute "blub" "bla")) + (cxml:text "Hi there.")))</pre> + <p> + Prints this to <tt>stream</tt>: + </p> + <pre><foo xyz="abc"> + <bar blub="bla"></bar> + Hi there. +</foo></pre> + + <heading>Help! CXML says 'URI scheme :HTTP not supported'</heading> + + <p> + By default, this error will occur when the DTD (or generally, any + entity) has an http:// URL as its system ID. CXML itself + understands only file:// URLs, but allows users to customize the + behaviour for all URLs. + </p> + + <p> + The are several solutions to this, covered in detail below: + <ul> + <li> + Load the DTD/entity from local files using an entity resolver + </li> + <li> + Skip parsing of the DTD/entity entirely by pretending it is + empty, again using an entity resolver. + </li> + <li> + Use a <em>catalog</em> to make CXML find DTDs in the local + filesystem automatically. + </li> + <li> + Teach CXML actually load DTDs using HTTP. + </li> + </ul> + </p> + + <p> + Here are the example files for the following solutions to this + problem: + </p> + + <a href="http://www.lichteblau.com/blubba/dtdexample.xml"> + <tt>dtdexample.xml</tt>:</a> + <pre><!DOCTYPE test SYSTEM 'http://www.lichteblau.com/blubba/dtdexample.dtd'> +<test a='b'>blub<child/></test></pre> + + <a href="http://www.lichteblau.com/blubba/dtdexample.dtd"> + <tt>dtdexample.dtd</tt></a>: + <pre><!ELEMENT test (#PCDATA|child)*> +<!ATTLIST test + a CDATA #REQUIRED + > + +<!ELEMENT child EMPTY> +</pre> + + <heading>Loading DTDs from local files</heading> + + <p> + Use the :entity-resolver argument to <tt>parse-file</tt> to + specify a function that maps System IDs and Public IDs to local + files of your choice: + </p> + + <pre>(let ((uri "http://www.lichteblau.com/blubba/dtdexample.dtd") + (pathname "dtdexample.dtd")) + (flet ((resolver (pubid sysid) + (declare (ignore pubid)) + <b>(when (puri:uri= sysid (puri:parse-uri uri)) + (open pathname :element-type '(unsigned-byte 8)))</b>)) + (cxml:parse-file "dtdexample.xml" (cxml-dom:make-dom-builder) <b>:entity-resolver #'resolver</b>)))</pre> + + + <heading>Can I skip loading of DTDs entirely?</heading> + + <p> + Yes and no. + </p> + <p> + <i>Yes</i>, you can force CXML to do this, see the following example. + </p> + + <p> + But no, skipping the DTD will not actually work if the document + references entities declared in the DTD, especially since neither + SAX nor DOM are able to report unresolved entity references in + attributes. + </p> + + <p> + The trick to make CXML skip the DTD is to pretend that it is empty + by returning a zero-length stream instead: + </p> + + <pre>(flet ((resolver (pubid sysid) + (declare (ignore pubid sysid)) + <b>(flexi-streams:make-in-memory-input-stream nil)</b>)) + (cxml:parse-file "dtdexample.xml" (cxml-dom:make-dom-builder) <b>:entity-resolver #'resolver</b>))</pre> + + <heading> + Catalogs: How can I use the HTML DTD installed by my distribution? + </heading> + + <p> + Rather than writing an entity resolver function yourself, CXML can + use XML catalogs to find DTDs and entity files on your local system. + </p> + <p> + Catalogs are particularly helpful for DTDs that are + pre-installed. For example, most Linux distributions include a + package for the XHTML DTD. The DTD will reside in a + distribution-dependent location, which the central catalog file + points to. + </p> + <p>By default, CXML looks for the catalog in /etc/xml/catalog + (Linux) and /usr/local/share/xml/catalog.ports (FreeBSD). + </p> + <pre>* <b>(setf cxml:*catalog* (cxml:make-catalog))</b> +* (cxml:parse-file "test.xhtml" (cxml-dom:make-dom-builder))</pre> + + <heading> + Can I load DTDs through HTTP? + </heading> + + <p> + Sure, just use an entity-resolver function that does it. + </p> + <p> + Install <a href="http://weitz.de/drakma/">Drakma</a> and try this: + </p> + <pre>(flet ((resolver (pubid sysid) + (declare (ignore pubid)) + <b>(when (eq (puri:uri-scheme sysid) :http) + (drakma:http-request sysid :want-stream t))</b>)) + (cxml:parse-file "dtdexample.xml" (cxml-dom:make-dom-builder) <b>:entity-resolver #'resolver</b>))</pre> +</documentation> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/sax.html =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/sax.html 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/sax.html 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,773 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"> +<html> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> +<title>CXML SAX parser</title> +<link rel="stylesheet" type="text/css" href="cxml.css"> +</head> +<body> +<div class="sidebar"> +<div class="sidebar-title"><a href="index.html">Closure XML</a></div> +<div class="sidebar-main"><ul class="main"> +<li> +<a href="installation.html">Installing Closure XML</a><ul class="sub"> +<li><a href="installation.html#download"><b>Download</b></a></li> +<li><a href="installation.html#implementations">Implementation-specific notes</a></li> +<li><a href="installation.html#compilation">Compilation</a></li> +<li><a href="installation.html#tests">Tests</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li> +<li> +<a href="sax.html">SAX parsing and serialization</a><ul class="sub"> +<li><a href="sax.html#parser">Parsing and Validating</a></li> +<li><a href="sax.html#serialization">Serialization</a></li> +<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li> +<li><a href="sax.html#rods">Recoders</a></li> +<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li> +<li><a href="sax.html#catalogs">XML Catalogs</a></li> +<li><a href="sax.html#sax">SAX Interface</a></li> +</ul> +</li> +<li> +<a href="klacks.html">Klacks parser</a><ul class="sub"> +<li><a href="klacks.html#sources">Parsing incrementally</a></li> +<li><a href="klacks.html#convenience">Convenience functions</a></li> +<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li> +<li><a href="klacks.html#locator">Location information</a></li> +<li><a href="klacks.html#klacksax">Examples</a></li> +</ul> +</li> +<li> +<a href="dom.html">DOM implementation</a><ul class="sub"> +<li><a href="dom.html#parser">Parsing with the DOM builder</a></li> +<li><a href="dom.html#serialization">Serialization</a></li> +<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li> +</ul></div> +</div> + <h1>SAX parsing and serialization</h1> + + <a name="parser"></a> + + <p> + This chapter describes CXML's SAX-like parser interface. + </p> + <p> + The SAX layer is an important concept in CXML that users will + encounter in various situations: + </p> + <ul> + <li> + To <b>parse into DOM</b>, use the SAX parser as described below with + a <b>DOM builder</b> as the SAX handler. (Refer to <a href="dom.html#parser">make-dom-builder</a> for information about + DOM.) + </li> + <li> + <b>Serialization</b> is done using SAX, too. SAX handlers that + process and consume events without sending them to another + handler are called <i>sinks</i> in CXML. Serialization sinks + write XML output for the events they receive. For example, to + serialize DOM, use <tt>map-document</tt> to turn the DOM + document into SAX events together with a <tt>sink</tt> for + serialization. + </li> + <li> + SAX handlers can be chained together. Various SAX handlers + are offered that can be used in this way, transforming SAX + events before handing them to the next handler. This includes + handlers for <b>whitespace removal</b>, <b>namespace + normalization</b>, and rod-to-string <b>recoding</b>. + </li> + </ul> + <p> + However, SAX events are easier to generate than to process. That + is why CXML offers <i>Klacks</i>, a "pull-based" API in addition to SAX. + Klacks events are generally easier to process than to generate. + Please refer to the <a href="klacks.html">Klacks documentation</a> + for details. + </p> + + <h3>Parsing and Validating</h3> + <div style="border: 1px dotted black; width: 70%; padding: 1em"> + <p> + Old-style convenience functions: + </p> + <div style="font-weight: bold">Function CXML:PARSE-FILE (pathname handler &key ...)</div> + <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with a pathname argument. + (But note that <tt>cxml:parse-file</tt> interprets string + arguments as namestrings, while <tt>cxml:parse</tt> expects + literal XML documents.) + </p> + <div style="font-weight: bold">Function CXML:PARSE-STREAM (stream handler &key ...)</div> + <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with a stream argument.</p> + <div style="font-weight: bold">Function CXML:PARSE-OCTETS (octets handler &key ...)</div> + <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with an octet vector argument.</p> + <div style="font-weight: bold">Function CXML:PARSE-ROD (rod handler &key ...)</div> + <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with a string argument.</p> + </div> + + <h4> + New all-in-one parser interface: + </h4> + <div class="def">Function CXML:PARSE (input handler &key ...)</div> + <p> + Parse an XML document, where input is a string, pathname, octet + vector, or stream. + Return values from this function depend on the SAX handler used.<br> + Arguments: + </p> + <ul> + <li> + <tt>input</tt> -- one of:<br> + <ul> + <li> + <tt>pathname</tt> -- a Common Lisp pathname. + Open the file specified by the pathname and create a source for + the resulting stream. See below for information on how to + close the stream. + </li> + <li> +<tt>stream</tt> -- a Common Lisp stream with element-type + <tt>(unsigned-byte 8)</tt>. See below for information on how to + close the stream. + </li> + <li> + <tt>octets</tt> -- an <tt>(unsigned-byte 8)</tt> array. + The array is parsed directly, and interpreted according to the + encoding it specifies. + </li> + <li> + <tt>string</tt>/<tt>rod</tt> -- a rod (or <tt>string</tt> on + unicode-capable implementations). + Parses an XML document from the input string that has already + undergone external-format decoding. + </li> + </ul> + </li> + <li> +<tt>stream</tt> -- a Common Lisp stream with element-type + <tt>(unsigned-byte 8)</tt> +</li> + <li> +<tt>octets</tt> -- an <tt>(unsigned-byte 8)</tt> array</li> + <li> +<tt>handler</tt> -- a SAX handler</li> + </ul> + <p> + Common keyword arguments: + </p> + <ul> + <li> + <tt>validate</tt> -- A boolean. Defaults to + <tt>nil</tt>. If true, parse in validating mode, i.e. assert that + the document contains a DOCTYPE declaration and conforms to the + DTD declared. + </li> + <li> + <tt>dtd</tt> -- unless <tt>nil</tt>, an extid instance + specifying the external subset to load. This options overrides + the extid specified in the document type declaration, if any. + See below for <tt>make-extid</tt>. This option is useful + for verification purposes together with the <tt>root</tt> + and <tt>disallow-internal-subset</tt> arguments. + </li> + <li> +<tt>root</tt> -- the expected root element + name, or <tt>nil</tt> (the default). + </li> + <li> + <tt>entity-resolver</tt> -- <tt>nil</tt> or a function of two + arguments which is invoked for every entity referenced by the + document with the entity's Public ID (a rod) and System ID (an + URI object) as arguments. The function may either return + nil, CXML will then try to resolve the entity as usual. + Alternatively it may return a Common Lisp stream specialized on + <tt>(unsigned-byte 8)</tt> which will be used instead. (It may + also signal an error, of course, which can be useful to prohibit + parsed XML documents from including arbitrary files readable by + the parser.) + </li> + <li> + <tt>disallow-internal-subset</tt> -- a boolean. If true, signal + an error if the document contains an internal subset. + </li> + <li> + <tt>recode</tt> -- a boolean. (Ignored on Lisps with Unicode + support.) Recode rods to UTF-8 strings. Defaults to true. + Make sure to use <tt>utf8-dom:make-dom-builder</tt> if this + option is enabled and <tt>rune-dom:make-dom-builder</tt> + otherwise. + </li> + </ul> + <p> + Note: <tt>parse-rod</tt> assumes that the input has already been + decoded into Unicode runes and ignores the encoding + specified in the XML declaration, if any. + </p> + + <p> + <div class="def">Function CXML:PARSE-EMPTY-DOCUMENT (uri qname handler &key public-id system-id entity-resolver recode)</div> + </p> + <p> + Simulate parsing a document with a document element <tt>qname</tt> + having no attributes except for an optional namespace + declaration to <tt>uri</tt>. If an external ID is specified + (<tt>system-id</tt>, <tt>public-id</tt>), find, parse, and report + this DTD as if with <tt>parse-file</tt>, using the specified + entity resolver. + </p> + + <p> + <div class="def">Function CXML:PARSE-DTD-FILE (pathname)</div> + <div class="def">Function CXML:PARSE-DTD-STREAM (stream)</div> + Parse <a href="http://www.w3.org/TR/2000/REC-xml-20001006#NT-extSubset">declarations</a> + from a stand-alone file and return an object representing the DTD, + suitable as an argument to <tt>validate</tt>. + </p> + <ul> + <li> +<tt>pathname</tt> -- a Common Lisp pathname</li> + <li> +<tt>stream</tt> -- a Common Lisp stream with element-type + <tt>(unsigned-byte 8)</tt> +</li> + </ul> + + <p> + <div class="def">Function CXML:MAKE-EXTID (publicid systemid)</div> + Create an object representing the External ID composed + of the specified Public ID, a rod or <tt>nil</tt>, and System ID + (an URI object). + </p> + + <p> + <div class="def">Condition class CXML:XML-PARSE-ERROR ()</div> + Superclass of all conditions signalled by the CXML parser. + </p> + <p> + <div class="def">Condition class CXML:WELL-FORMEDNESS-VIOLATION (cxml:xml-parse-error)</div> + This condition is signalled for all well-formedness violations. + (Note that, when parsing document that is not well-formed in validating + mode, the parser might encounter validity errors before detecting + well-formedness problems, so also be prepared for <tt>validity-error</tt> + in that situation.) + </p> + <p> + <div class="def">Condition class CXML:VALIDITY-ERROR (cxml:xml-parse-error)</div> + Reports the violation of a validity constraint. + </p> + + <a name="serialization"></a> + <h3>Serialization</h3> + <p> + Serialization is performed using <tt>sink</tt> objects. There are + different kinds of sinks for output to lisp streams and vectors in + various flavours. + </p> + <p> + Technically, sinks are SAX handlers that write XML output for SAX + events sent to them. In practise, user code would normally not + generate those SAX events manually, and instead use a function + like <a href="dom.html#serialization">dom:map-document</a> or <a href="xmls-compat.html">xmls-compat:map-node</a> to serialize an + in-memory document. + </p> + <p> + In addition to <tt>map-document</tt>, cxml has a set of + convenience macros for serialization (see below for + <tt>with-xml-output</tt>, <tt>with-element</tt>, etc). + </p> + + <div style="background-color: #ddddff"> + Portable sinks:<br> + <span class="def">Function CXML:MAKE-OCTET-VECTOR-SINK (&rest keys) => sink</span><br> + <span class="def">Function CXML:MAKE-OCTET-STREAM-SINK (stream &rest keys) => sink</span><br> + <span class="def">Function CXML:MAKE-ROD-SINK (&rest keys) => sink</span><br> + <br> + Only on Lisps with Unicode support:<br> + <span class="def">Function CXML:MAKE-STRING-SINK</span> -- alias for <tt>cxml:make-rod-sink</tt><br> + <span class="def">Function CXML:MAKE-CHARACTER-STREAM-SINK (stream &rest keys) => sink</span><br> + <br> + Only on Lisps <em>without</em> Unicode support:<br> + <span class="def">Function CXML:MAKE-STRING-SINK/UTF8 (&rest keys) => sink</span><br> + <span class="def">Function CXML:MAKE-CHARACTER-STREAM-SINK/UTF8 (stream &rest keys) => sink</span><br> + </div> + <p> + Return a SAX serialization handle. + </p> + <ul> + <li> + The <tt>-octet-</tt> functions write the document encoded into + UTF-8. + <tt>make-octet-stream-sink</tt> works with Lisp streams of + element-type <tt>(unsigned-byte 8)</tt>. + <tt>make-octet-vector-sink</tt> returns a vector of + <tt>(unsigned-byte 8)</tt>. + </li> + <li> + <tt>make-character-stream-sink</tt> works with character + streams. It serializes the document into characters <em>without + encoding it into an external format</em>. When using these + functions, <em>take care to avoid encoding the result into + an incorrect external format</em>. (Note that characters undergo + external format conversion when written to a character stream. + If the document's XML declaration specifies an encoding, make + sure to specify this encoding as the external format if and when + writing the serialized document to a character stream. If the + document does not specify an encoding, either UTF-8 or UTF-16 + must be used.) This function is available only on Lisps with + unicode support. + </li> + <li> + <tt>make-rod-sink</tt> serializes the document into a vector of + runes <em>without encoding it into an external format</em>. + (On Lisp with unicode support, the result will be a string; + otherwise, a vector of character codes will be returned.) + The warnings given for <tt>make-character-stream-sink</tt> + apply to this function as well. + </li> + <li> + The <tt>/utf8</tt> functions write the document encoded into + characters representing a UTF-8 encoding. + When using these functions, <em>take care to avoid encoding the + result</em> into an external format for a second time. (Note + that characters undergo external format conversion when written + to a character stream. Since these functions already perform + external format conversion, make sure to specify an external + format that does "nothing" if and when writing the serialized document + to a character stream. ISO-8859-1 external formats usually + achieve the desired effect.) + <tt>make-character-stream-sink/utf8</tt> works with character streams. + <tt>make-string-sink/utf8</tt> returns a string. + These functions are available only on Lisps without unicode support. + </li> + </ul> + <p>Keyword arguments:</p> + <ul> + <li> + <tt>canonical</tt> -- canonical form, one of NIL, T, 1, 2 + </li> + <li> + <tt>indentation</tt> -- indentation level. An integer or <tt>nil</tt>. + </li> + </ul> + <p> + The following <tt>canonical</tt> values are allowed: + </p> + <ul> + <li> + <tt>t</tt> or <tt>1</tt>: <a href="http://www.w3.org/TR/2001/REC-xml-c14n-20010315">Canonical + XML</a> + </li> + <li> + <tt>2</tt>: <a href="http://dev.w3.org/cvsweb/~checkout~/2001/XML-Test-Suite/xmlconf/sun/cxml.ht…">Second + Canonical Form</a> + </li> + <li> + <tt>NIL</tt>: Use a more readable non-canonical representation. + </li> + </ul> + <p> + An internal subset will be included in the result regardless of + the <tt>canonical</tt> setting. It is the responsibility of the + caller to not report an internal subset for + canonical <= 1, or only notations as required for + canonical = 2. For example, the + <tt>include-doctype</tt> argument to <tt>dom:map-document</tt> + should be set to <tt>nil</tt> for the former behaviour and + <tt>:canonical-notations</tt> for the latter. + </p> + <p> + With an <tt>indentation</tt> level, pretty-print the XML by + inserting additional whitespace. Note that indentation + changes the document model and should only be used if whitespace + does not matter to the application. + </p> + + <p> + <div class="def">Macro CXML:WITH-XML-OUTPUT (sink &body body) => sink-specific result</div> + <div class="def">Macro CXML:WITH-NAMESPACE ((prefix uri) &body body) => result</div> + <div class="def">Macro CXML:WITH-ELEMENT (qname &body body) => result</div> + <div class="def">Macro CXML:WITH-ELEMENT* ((prefix lname) &body body) => result</div> + <div class="def">Function CXML:ATTRIBUTE (qname value) => value</div> + <div class="def">Generic Function CXML:UNPARSE-ATTRIBUTE (value) => string</div> + <div class="def">Function CXML:ATTRIBUTE* (prefix lname value) => value</div> + <div class="def">Function CXML:TEXT (data) => data</div> + <div class="def">Function CXML:CDATA (data) => data</div> + <div class="def">Function CXML:doctype (name public-id system-id &optional internal-subset)</div> + Convenience syntax for event-based serialization. + </p> + <p> + Example: + </p> + <pre>(with-xml-output (make-octet-stream-sink stream :indentation 2 :canonical nil) + (with-element "foo" + (attribute "xyz" "abc") + (with-element "bar" + (attribute "blub" "bla")) + (text "Hi there.")))</pre> + <p> + Prints this to <tt>stream</tt>: + </p> + <pre><foo xyz="abc"> + <bar blub="bla"></bar> + Hi there. +</foo></pre> + + <p> + <div class="def">Macro XHTML-GENERATOR:WITH-XHTML (sink &rest forms)</div> + <div class="def">Macro XHTML-GENERATOR:WRITE-DOCTYPE (sink)</div> + Macro <tt>with-xhtml</tt> is a modified version of + Franz' <tt>htmlgen</tt> works as a SAX driver for XHTML. + It aims to be a plug-in replacement for the <tt>html</tt> macro. + </p> + <p> + <tt>xhtmlgen</tt> is included as <tt>contrib/xhtmlgen.lisp</tt> in + the cxml distribution. Example: + </p> + <pre>(let ((sink (cxml:make-character-stream-sink *standard-output*))) + (sax:start-document sink) + (xhtml-generator:write-doctype sink) + (xhtml-generator:with-html sink + (:html + (:head + (:title "Titel")) + (:body + ((:p "style" "font-weight: bold") + "Inhalt") + (:ul + (:li "Eins") + (:li "Zwei") + (:li "Drei"))))) + (sax:end-document sink))</pre> + + <a name="misc"></a> + <h3>Miscellaneous SAX handlers</h3> + <p> + <div class="def">Function CXML:MAKE-VALIDATOR (dtd root)</div> + Create a SAX handler which validates against a DTD instance. + The document's root element must be named <tt>root</tt>. + Used with <tt>dom:map-document</tt>, this validates a document + object as if by re-reading it with a validating parser, except + that declarations recorded in the document instance are completely + ignored.<br> + Example: + </p> + <pre>(let ((d (parse-file "~/test.xml" (cxml-dom:make-dom-builder))) + (x (parse-dtd-file "~/test.dtd"))) + (dom:map-document (cxml:make-validator x #"foo") d))</pre> + + <p> + <div class="def">Class CXML:BROADCAST-HANDLER ()</div> + <div class="def">Accessor CXML:BROADCAST-HANDLER-HANDLERS</div> + <div class="def">Function CXML:MAKE-BROADCAST-HANDLER (&rest handlers)</div> + <tt>broadcast-handler</tt> is a SAX handler which passes every event it + receives on to each of several chained handlers, somewhat similar + to the way a <tt>broadcast-stream</tt> works. + </p> + <p> + You can subclass <tt>broadcast-stream</tt> to modify the events + before they are being passed on. Define methods on your handler + class for the events to be modified. All other events will pass + through to the chained handlers unmodified. + </p> + <p> + Broadcast handler functions return the result of calling the event + function on the <i>last</i> handler in the list. In particular, + the overall result from <tt>sax:end-document</tt> will be ignored + for all other handlers. + </p> + + <p> + <div class="def">Class CXML:SAX-PROXY (broadcast-handler)</div> + <div class="def">Accessor CXML:PROXY-CHAINED-HANDLER</div> + <tt>sax-proxy</tt> is a subclass of <tt>broadcast-handler</tt> + which sends events to exactly one chained handler. This class is + still included for compatibility with older versions of + CXML which did not include the more + general <tt>broadcast-handler</tt> yet, but has been retrofitted + as a subclass of the latter. + </p> + + <p> + <div class="def">Accessor CXML:MAKE-NAMESPACE-NORMALIZER (next-handler)</div> + </p> + <p> + Return a SAX handler that performs <a href="http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/namespaces-algorith…">DOM + 3-style namespace normalization</a> on attribute lists in + <tt>start-element</tt> events before passing them on the next + handler. + </p> + <p> + <div class="def">Function CXML:MAKE-WHITESPACE-NORMALIZER (chained-handler &optional dtd)</div> + Return a SAX handler which removes whitespace from elements that + have <em>element content</em> and have not been declared to + preserve space using an xml:space attribute. + </p> + <p>Example:</p> + <pre>(cxml:parse-file "example.xml" + (cxml:make-whitespace-normalizer (cxml-dom:make-dom-builder)) + :validate t)</pre> + <p>Example input:</p> + <pre><!DOCTYPE test [ +<!ELEMENT test (foo,bar*)> +<!ATTLIST test a CDATA #IMPLIED> +<!ELEMENT foo #PCDATA> +<!ELEMENT bar (foo?)> +<!ATTLIST bar xml:space (default|preserve) "default"> +]> +<test a='b'> + <foo> </foo> + <bar> </bar> + <bar xml:space="preserve"> </bar> +</test> +</pre> + <p>Example result:</p> + <pre><test a="b"><foo> </foo><bar></bar><bar xml:space="preserve"> </bar></test></pre> + + <a name="rods"></a> + <h3>Recoders</h3> + <p> + Recoders are a mechanism used by CXML internally on Lisp implementations + without Unicode support to recode UTF-16 vectors (rods) of + integers (runes) into UTF-8 strings. + </p> + <p> + User code does not usually need to deal with recoders in current + versions of CXML. + </p> + <p> + <div class="def">Function CXML:MAKE-RECODER (chained-handler recoder-fn)</div> + Return a SAX handler which passes all events on to + <tt>chained-handler</tt> after converting all strings and rods + using <tt>recoder-fn</tt>, a function of one argument. + </p> + + <a name="dtdcache"></a> + <h3>Caching of DTD Objects</h3> + <p> + To avoid spending time parsing the same DTD over and over again, + CXML can cache DTD objects. The parser consults + <tt>cxml:*dtd-cache*</tt> whenever it is looking for an external + subset in a document which does not have an internal subset and + uses the cached DTD instance if one is present in the cache for + the System ID in question. + </p> + <p> + Note that DTDs do not expire from the cache automatically. + (Future versions of CXML might introduce automatic checks for + outdated DTDs.) + </p> + <p> + <div class="def">Variable CXML:*DTD-CACHE*</div> + The DTD cache object consulted by the parser when it needs a DTD. + </p> + <p> + <div class="def">Function CXML:MAKE-DTD-CACHE ()</div> + Return a new, empty DTD cache object. + </p> + <p> + <div class="def">Variable CXML:*CACHE-ALL-DTDS*</div> + If true, instructs the parser to enter all DTDs that could have + been cached into <tt>*dtd-cache*</tt> if they were not cached + already. Defaults to <tt>nil</tt>. + </p> + <p> + <div class="def">Reader CXML:GETDTD (uri dtd-cache)</div> + Return a cached instance of the DTD at <tt>uri</tt>, if present in + the cache, or <tt>nil</tt>. + </p> + <p> + <div class="def">Writer CXML:GETDTD (uri dtd-cache)</div> + Enter a new value for <tt>uri</tt> into <tt>dtd-cache</tt>. + </p> + <p> + <div class="def">Function CXML:REMDTD (uri dtd-cache)</div> + Ensure that no DTD is recorded for <tt>uri</tt> in the cache and + return true if such a DTD was present. + </p> + <p> + <div class="def">Function CXML:CLEAR-DTD-CACHE (dtd-cache)</div> + Remove all entries from <tt>dtd-cache</tt>. + </p> + <p> + <em>fixme:</em> thread-safety + </p> + + <a name="saxparser"></a> + <h3>Location information</h3> + <p> + <div class="def">Class SAX:SAX-PARSER ()</div> + A class providing location information through an + implementation-specific subclass. Parsers will use + <tt>sax:register-sax-parser</tt> to pass their parser instance to + the handler. The easiest way to receive sax parsers instances is + to inherit from sax-parser-mixin when defining a sax handler. + </p> + <p> + <div class="def">Class SAX:SAX-PARSER-MIXIN ()</div> + A mixin for sax handler classes that records the sax handler + object for use with the following functions. Trampoline methods + are provided that allow those functions to be called directly on + the sax-parser-mixin. + </p> + <p> + <div class="def">Function SAX:SAX-HANDLER (sax-handler-mixin) => sax-handler</div> + Return the sax-parser instance recorded by this handler, or NIL. + </p> + <p> + <div class="def">Function SAX:LINE-NUMBER (sax-parser)</div> + Return an approximation of the current line number, or NIL. + </p> + <p> + <div class="def">Function SAX:COLUMN-NUMBER (sax-parser)</div> + Return an approximation of the current column number, or NIL. + </p> + <p> + <div class="def">Function SAX:SYSTEM-ID (sax-parser)</div> + Return the URI of the document being parsed. This is either the + main document, or the entity's system ID while contents of a parsed + general external entity are being processed. + </p> + <p> + <div class="def">Function SAX:XML-BASE (sax-parser)</div> + Return the [Base URI] of the current element. This URI can differ from + the value returned by <tt>sax:system-id</tt> if xml:base + attributes are present. + </p> + + <a name="catalogs"></a> + <h3>XML Catalogs</h3> + <p> + External entities (for example, DTDs) are referred to using their + Public and System IDs. Usually the System ID, a URI, is used to + locate the entity. CXML itself handles only file://-URIs, but + many System IDs in practical use are http://-URIs. There are two + different mechanims applications can use to allow CXML to locate + entities using arbitrary Public ID or System ID: + </p> + <ul> + <li> + User-defined entity resolvers can be used to open entities using + arbitrary protocols. For example, an entity resolver could + handle all System-IDs with the <tt>http</tt> scheme using some + HTTP library. Refer to the description of the + <tt>entity-resolver</tt> keyword argument to parser functions (see <a href="#parser"><tt>cxml:parse-file</tt></a>) to more + information on entity resolvers. + </li> + <li> + XML Catalogs are (local) tables in XML syntax which map External + IDs to alternative System IDs. If, say, the xhtml DTD is + present in the local file system and the local copy has been + registered with the XML catalog, CXML will use the local copy of + the DTD instead of trying to open the version available using HTTP. + </li> + </ul> + <p> + This section describes XML Catalogs, the second solution. CXML + implements <a href="http://www.oasis-open.org/committees/entity/spec.html">Oasis + XML Catalogs</a>. + </p> + <p> + <div class="def">Variable CXML:*CATALOG*</div> + The XML Catalog object consulted by the parser before trying to + open an entity. Initially <tt>nil</tt>. + </p> + <p> + <div class="def">Variable CXML:*PREFER*</div> + The default "prefer" mode from the Catalog specification, one + of <tt>:public</tt> or <tt>:system</tt>. Defaults + to <tt>:public</tt>. + </p> + <p> + <div class="def">Function CXML:MAKE-CATALOG (&optional uris)</div> + Return a catalog object for the catalog files specified. + </p> + <p> + <div class="def">Function CXML:RESOLVE-URI (uri catalog)</div> + Look up <tt>uri</tt> in <tt>catalog</tt> and return the + resulting URI, or <tt>nil</tt> if no match was found. + </p> + <p> + <div class="def">Function CXML:RESOLVE-EXTID (publicid systemid catalog)</div> + Look up the External ID (<tt>publicid</tt>, <tt>systemid</tt>) + in <tt>catalog</tt> and return the resulting URI, or <tt>nil</tt> + if no match was found. + </p> + <p> + Example: + </p> + <pre>* (setf cxml:*catalog* nil) +* (cxml:parse-file "test.xhtml" nil) +=> Error: URI scheme :HTTP not supported + +* (setf cxml:*catalog* (cxml:make-catalog)) +* (cxml:parse-file "test.xhtml" nil) +;; no error! +NIL</pre> + <p> + Note that parsed catalog files are cached in the catalog object. + Catalog files cached do not expire automatically. To ensure that + all catalog files are parsed again, create a new catalog object. + </p> + + <a name="sax"></a> + <h2>SAX Interface</h2> + <p> + A SAX handler is an arbitrary objects that implements some of the + generic functions in the SAX package. Note that no default + handler class is necessary, because all generic functions have default + methods which do nothing. SAX functions are: + <div class="def">Function SAX:START-DOCUMENT (handler)</div> + <div class="def">Function SAX:END-DOCUMENT (handler)</div> + <br> + <div class="def">Function SAX:START-ELEMENT (handler namespace-uri local-name qname attributes)</div> + <div class="def">Function SAX:END-ELEMENT (handler namespace-uri local-name qname)</div> + <div class="def">Function SAX:START-PREFIX-MAPPING (handler prefix uri)</div> + <div class="def">Function SAX:END-PREFIX-MAPPING (handler prefix)</div> + <div class="def">Function SAX:PROCESSING-INSTRUCTION (handler target data)</div> + <div class="def">Function SAX:COMMENT (handler data)</div> + <div class="def">Function SAX:START-CDATA (handler)</div> + <div class="def">Function SAX:END-CDATA (handler)</div> + <div class="def">Function SAX:CHARACTERS (handler data)</div> + <br> + <div class="def">Function SAX:START-DTD (handler name public-id system-id)</div> + <div class="def">Function SAX:END-DTD (handler)</div> + <div class="def">Function SAX:START-INTERNAL-SUBSET (handler)</div> + <div class="def">Function SAX:END-INTERNAL-SUBSET (handler)</div> + <div class="def">Function SAX:UNPARSED-ENTITY-DECLARATION (handler name public-id system-id notation-name)</div> + <div class="def">Function SAX:EXTERNAL-ENTITY-DECLARATION (handler kind name public-id system-id)</div> + <div class="def">Function SAX:INTERNAL-ENTITY-DECLARATION (handler kind name value)</div> + <div class="def">Function SAX:NOTATION-DECLARATION (handler name public-id system-id)</div> + <div class="def">Function SAX:ELEMENT-DECLARATION (handler name model)</div> + <div class="def">Function SAX:ATTRIBUTE-DECLARATION (handler ename aname type default)</div> + <br> + <div class="def">Accessor SAX:ATTRIBUTE-PREFIX (attribute)</div> + <div class="def">Accessor SAX:ATTRIBUTE-NAMESPACE-URI (attribute)</div> + <div class="def">Accessor SAX:ATTRIBUTE-LOCAL-NAME (attribute)</div> + <div class="def">Accessor SAX:ATTRIBUTE-QNAME (attribute)</div> + <div class="def">Accessor SAX:ATTRIBUTE-SPECIFIED-P (attribute)</div> + <div class="def">Accessor SAX:ATTRIBUTE-VALUE (attribute)</div> + <br> + <div class="def">Function SAX:FIND-ATTRIBUTE (qname attributes)</div> + <div class="def">Function SAX:FIND-ATTRIBUTE-NS (uri lname attributes)</div> + </p> + <p> + The entity declaration methods are similar to Java SAX + definitions, but parameter entities are distinguished from + general entities not by a <tt>%</tt> prefix to the name, but by + the <tt>kind</tt> argument, either <tt>:parameter</tt> or + <tt>:general</tt>. + </p> + <p> + The arguments to <tt>sax:element-declaration</tt> and + <tt>sax:attribute-declaration</tt> differ significantly from their + Java counterparts. + </p> + <p> + <i>fixme</i>: For more information on these functions refer to the docstrings. + </p> +</body> +</html> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/sax.xml =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/sax.xml 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/sax.xml 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,724 @@ +<documentation title="CXML SAX parser"> + <h1>SAX parsing and serialization</h1> + + <a name="parser"/> + + <p> + This chapter describes CXML's SAX-like parser interface. + </p> + <p> + The SAX layer is an important concept in CXML that users will + encounter in various situations: + </p> + <ul> + <li> + To <b>parse into DOM</b>, use the SAX parser as described below with + a <b>DOM builder</b> as the SAX handler. (Refer to <a + href="dom.html#parser">make-dom-builder</a> for information about + DOM.) + </li> + <li> + <b>Serialization</b> is done using SAX, too. SAX handlers that + process and consume events without sending them to another + handler are called <i>sinks</i> in CXML. Serialization sinks + write XML output for the events they receive. For example, to + serialize DOM, use <tt>map-document</tt> to turn the DOM + document into SAX events together with a <tt>sink</tt> for + serialization. + </li> + <li> + SAX handlers can be chained together. Various SAX handlers + are offered that can be used in this way, transforming SAX + events before handing them to the next handler. This includes + handlers for <b>whitespace removal</b>, <b>namespace + normalization</b>, and rod-to-string <b>recoding</b>. + </li> + </ul> + <p> + However, SAX events are easier to generate than to process. That + is why CXML offers <i>Klacks</i>, a "pull-based" API in addition to SAX. + Klacks events are generally easier to process than to generate. + Please refer to the <a href="klacks.html">Klacks documentation</a> + for details. + </p> + + <h3>Parsing and Validating</h3> + <div style="border: 1px dotted black; + width: 70%; + padding: 1em"> + <p> + Old-style convenience functions: + </p> + <div style="font-weight: bold">Function CXML:PARSE-FILE (pathname handler &key ...)</div> + <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with a pathname argument. + (But note that <tt>cxml:parse-file</tt> interprets string + arguments as namestrings, while <tt>cxml:parse</tt> expects + literal XML documents.) + </p> + <div style="font-weight: bold">Function CXML:PARSE-STREAM (stream handler &key ...)</div> + <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with a stream argument.</p> + <div style="font-weight: bold">Function CXML:PARSE-OCTETS (octets handler &key ...)</div> + <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with an octet vector argument.</p> + <div style="font-weight: bold">Function CXML:PARSE-ROD (rod handler &key ...)</div> + <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with a string argument.</p> + </div> + + <h4> + New all-in-one parser interface: + </h4> + <div class="def">Function CXML:PARSE (input handler &key ...)</div> + <p> + Parse an XML document, where input is a string, pathname, octet + vector, or stream. + Return values from this function depend on the SAX handler used.<br/> + Arguments: + </p> + <ul> + <li> + <tt>input</tt> -- one of:<br/> + <ul> + <li> + <tt>pathname</tt> -- a Common Lisp pathname. + Open the file specified by the pathname and create a source for + the resulting stream. See below for information on how to + close the stream. + </li> + <li><tt>stream</tt> -- a Common Lisp stream with element-type + <tt>(unsigned-byte 8)</tt>. See below for information on how to + close the stream. + </li> + <li> + <tt>octets</tt> -- an <tt>(unsigned-byte 8)</tt> array. + The array is parsed directly, and interpreted according to the + encoding it specifies. + </li> + <li> + <tt>string</tt>/<tt>rod</tt> -- a rod (or <tt>string</tt> on + unicode-capable implementations). + Parses an XML document from the input string that has already + undergone external-format decoding. + </li> + </ul> + </li> + <li><tt>stream</tt> -- a Common Lisp stream with element-type + <tt>(unsigned-byte 8)</tt></li> + <li><tt>octets</tt> -- an <tt>(unsigned-byte 8)</tt> array</li> + <li><tt>handler</tt> -- a SAX handler</li> + </ul> + <p> + Common keyword arguments: + </p> + <ul> + <li> + <tt>validate</tt> -- A boolean.  Defaults to + <tt>nil</tt>. If true, parse in validating mode, i.e. assert that + the document contains a DOCTYPE declaration and conforms to the + DTD declared. + </li> + <li> + <tt>dtd</tt> -- unless <tt>nil</tt>, an extid instance + specifying the external subset to load. This options overrides + the extid specified in the document type declaration, if any. + See below for <tt>make-extid</tt>. This option is useful + for verification purposes together with the <tt>root</tt> + and <tt>disallow-internal-subset</tt> arguments. + </li> + <li><tt>root</tt> -- the expected root element + name, or <tt>nil</tt> (the default). + </li> + <li> + <tt>entity-resolver</tt> -- <tt>nil</tt> or a function of two + arguments which is invoked for every entity referenced by the + document with the entity's Public ID (a rod) and System ID (an + URI object) as arguments. The function may either return + nil, CXML will then try to resolve the entity as usual. + Alternatively it may return a Common Lisp stream specialized on + <tt>(unsigned-byte 8)</tt> which will be used instead. (It may + also signal an error, of course, which can be useful to prohibit + parsed XML documents from including arbitrary files readable by + the parser.) + </li> + <li> + <tt>disallow-internal-subset</tt> -- a boolean. If true, signal + an error if the document contains an internal subset. + </li> + <li> + <tt>recode</tt> -- a boolean. (Ignored on Lisps with Unicode + support.) Recode rods to UTF-8 strings. Defaults to true. + Make sure to use <tt>utf8-dom:make-dom-builder</tt> if this + option is enabled and <tt>rune-dom:make-dom-builder</tt> + otherwise. + </li> + </ul> + <p> + Note: <tt>parse-rod</tt> assumes that the input has already been + decoded into Unicode runes and ignores the encoding + specified in the XML declaration, if any. + </p> + + <p> + <div class="def">Function CXML:PARSE-EMPTY-DOCUMENT (uri qname handler &key public-id system-id entity-resolver recode)</div> + </p> + <p> + Simulate parsing a document with a document element <tt>qname</tt> + having no attributes except for an optional namespace + declaration to <tt>uri</tt>. If an external ID is specified + (<tt>system-id</tt>, <tt>public-id</tt>), find, parse, and report + this DTD as if with <tt>parse-file</tt>, using the specified + entity resolver. + </p> + + <p> + <div class="def">Function CXML:PARSE-DTD-FILE (pathname)</div> + <div class="def">Function CXML:PARSE-DTD-STREAM (stream)</div> + Parse <a + href="http://www.w3.org/TR/2000/REC-xml-20001006#NT-extSubset">declarations</a> + from a stand-alone file and return an object representing the DTD, + suitable as an argument to <tt>validate</tt>. + </p> + <ul> + <li><tt>pathname</tt> -- a Common Lisp pathname</li> + <li><tt>stream</tt> -- a Common Lisp stream with element-type + <tt>(unsigned-byte 8)</tt></li> + </ul> + + <p> + <div class="def">Function CXML:MAKE-EXTID (publicid systemid)</div> + Create an object representing the External ID composed + of the specified Public ID, a rod or <tt>nil</tt>, and System ID + (an URI object). + </p> + + <p> + <div class="def">Condition class CXML:XML-PARSE-ERROR ()</div> + Superclass of all conditions signalled by the CXML parser. + </p> + <p> + <div class="def">Condition class CXML:WELL-FORMEDNESS-VIOLATION (cxml:xml-parse-error)</div> + This condition is signalled for all well-formedness violations. + (Note that, when parsing document that is not well-formed in validating + mode, the parser might encounter validity errors before detecting + well-formedness problems, so also be prepared for <tt>validity-error</tt> + in that situation.) + </p> + <p> + <div class="def">Condition class CXML:VALIDITY-ERROR (cxml:xml-parse-error)</div> + Reports the violation of a validity constraint. + </p> + + <a name="serialization"/> + <h3>Serialization</h3> + <p> + Serialization is performed using <tt>sink</tt> objects. There are + different kinds of sinks for output to lisp streams and vectors in + various flavours. + </p> + <p> + Technically, sinks are SAX handlers that write XML output for SAX + events sent to them. In practise, user code would normally not + generate those SAX events manually, and instead use a function + like <a href="dom.html#serialization">dom:map-document</a> or <a + href="xmls-compat.html">xmls-compat:map-node</a> to serialize an + in-memory document. + </p> + <p> + In addition to <tt>map-document</tt>, cxml has a set of + convenience macros for serialization (see below for + <tt>with-xml-output</tt>, <tt>with-element</tt>, etc). + </p> + + <div style="background-color: #ddddff"> + Portable sinks:<br/> + <span class="def">Function CXML:MAKE-OCTET-VECTOR-SINK (&rest keys) => sink</span><br/> + <span class="def">Function CXML:MAKE-OCTET-STREAM-SINK (stream &rest keys) => sink</span><br/> + <span class="def">Function CXML:MAKE-ROD-SINK (&rest keys) => sink</span><br/> + <br/> + Only on Lisps with Unicode support:<br/> + <span class="def">Function CXML:MAKE-STRING-SINK</span> -- alias for <tt>cxml:make-rod-sink</tt><br/> + <span class="def">Function CXML:MAKE-CHARACTER-STREAM-SINK (stream &rest keys) => sink</span><br/> + <br/> + Only on Lisps <em>without</em> Unicode support:<br/> + <span class="def">Function CXML:MAKE-STRING-SINK/UTF8 (&rest keys) => sink</span><br/> + <span class="def">Function CXML:MAKE-CHARACTER-STREAM-SINK/UTF8 (stream &rest keys) => sink</span><br/> + </div> + <p> + Return a SAX serialization handle. + </p> + <ul> + <li> + The <tt>-octet-</tt> functions write the document encoded into + UTF-8. + <tt>make-octet-stream-sink</tt> works with Lisp streams of + element-type <tt>(unsigned-byte 8)</tt>. + <tt>make-octet-vector-sink</tt> returns a vector of + <tt>(unsigned-byte 8)</tt>. + </li> + <li> + <tt>make-character-stream-sink</tt> works with character + streams. It serializes the document into characters <em>without + encoding it into an external format</em>. When using these + functions, <em>take care to avoid encoding the result into + an incorrect external format</em>. (Note that characters undergo + external format conversion when written to a character stream. + If the document's XML declaration specifies an encoding, make + sure to specify this encoding as the external format if and when + writing the serialized document to a character stream. If the + document does not specify an encoding, either UTF-8 or UTF-16 + must be used.) This function is available only on Lisps with + unicode support. + </li> + <li> + <tt>make-rod-sink</tt> serializes the document into a vector of + runes <em>without encoding it into an external format</em>. + (On Lisp with unicode support, the result will be a string; + otherwise, a vector of character codes will be returned.) + The warnings given for <tt>make-character-stream-sink</tt> + apply to this function as well. + </li> + <li> + The <tt>/utf8</tt> functions write the document encoded into + characters representing a UTF-8 encoding. + When using these functions, <em>take care to avoid encoding the + result</em> into an external format for a second time. (Note + that characters undergo external format conversion when written + to a character stream. Since these functions already perform + external format conversion, make sure to specify an external + format that does "nothing" if and when writing the serialized document + to a character stream. ISO-8859-1 external formats usually + achieve the desired effect.) + <tt>make-character-stream-sink/utf8</tt> works with character streams. + <tt>make-string-sink/utf8</tt> returns a string. + These functions are available only on Lisps without unicode support. + </li> + </ul> + <p>Keyword arguments:</p> + <ul> + <li> + <tt>canonical</tt> -- canonical form, one of NIL, T, 1, 2 + </li> + <li> + <tt>indentation</tt> -- indentation level. An integer or <tt>nil</tt>. + </li> + </ul> + <p> + The following <tt>canonical</tt> values are allowed: + </p> + <ul> + <li> + <tt>t</tt> or <tt>1</tt>: <a + href="http://www.w3.org/TR/2001/REC-xml-c14n-20010315">Canonical + XML</a> + </li> + <li> + <tt>2</tt>: <a + href="http://dev.w3.org/cvsweb/~checkout~/2001/XML-Test-Suite/xmlconf/sun/cxml.ht…">Second + Canonical Form</a> + </li> + <li> + <tt>NIL</tt>: Use a more readable non-canonical representation. + </li> + </ul> + <p> + An internal subset will be included in the result regardless of + the <tt>canonical</tt> setting. It is the responsibility of the + caller to not report an internal subset for + canonical <= 1, or only notations as required for + canonical = 2. For example, the + <tt>include-doctype</tt> argument to <tt>dom:map-document</tt> + should be set to <tt>nil</tt> for the former behaviour and + <tt>:canonical-notations</tt> for the latter. + </p> + <p> + With an <tt>indentation</tt> level, pretty-print the XML by + inserting additional whitespace.  Note that indentation + changes the document model and should only be used if whitespace + does not matter to the application. + </p> + + <p> + <div class="def">Macro CXML:WITH-XML-OUTPUT (sink &body body) => sink-specific result</div> + <div class="def">Macro CXML:WITH-NAMESPACE ((prefix uri) &body body) => result</div> + <div class="def">Macro CXML:WITH-ELEMENT (qname &body body) => result</div> + <div class="def">Macro CXML:WITH-ELEMENT* ((prefix lname) &body body) => result</div> + <div class="def">Function CXML:ATTRIBUTE (qname value) => value</div> + <div class="def">Generic Function CXML:UNPARSE-ATTRIBUTE (value) => string</div> + <div class="def">Function CXML:ATTRIBUTE* (prefix lname value) => value</div> + <div class="def">Function CXML:TEXT (data) => data</div> + <div class="def">Function CXML:CDATA (data) => data</div> + <div class="def">Function CXML:doctype (name public-id system-id &optional internal-subset)</div> + Convenience syntax for event-based serialization. + </p> + <p> + Example: + </p> + <pre>(with-xml-output (make-octet-stream-sink stream :indentation 2 :canonical nil) + (with-element "foo" + (attribute "xyz" "abc") + (with-element "bar" + (attribute "blub" "bla")) + (text "Hi there.")))</pre> + <p> + Prints this to <tt>stream</tt>: + </p> + <pre><foo xyz="abc"> + <bar blub="bla"></bar> + Hi there. +</foo></pre> + + <p> + <div class="def">Macro XHTML-GENERATOR:WITH-XHTML (sink &rest forms)</div> + <div class="def">Macro XHTML-GENERATOR:WRITE-DOCTYPE (sink)</div> + Macro <tt>with-xhtml</tt> is a modified version of + Franz' <tt>htmlgen</tt> works as a SAX driver for XHTML. + It aims to be a plug-in replacement for the <tt>html</tt> macro. + </p> + <p> + <tt>xhtmlgen</tt> is included as <tt>contrib/xhtmlgen.lisp</tt> in + the cxml distribution. Example: + </p> + <pre>(let ((sink (cxml:make-character-stream-sink *standard-output*))) + (sax:start-document sink) + (xhtml-generator:write-doctype sink) + (xhtml-generator:with-html sink + (:html + (:head + (:title "Titel")) + (:body + ((:p "style" "font-weight: bold") + "Inhalt") + (:ul + (:li "Eins") + (:li "Zwei") + (:li "Drei"))))) + (sax:end-document sink))</pre> + + <a name="misc"/> + <h3>Miscellaneous SAX handlers</h3> + <p> + <div class="def">Function CXML:MAKE-VALIDATOR (dtd root)</div> + Create a SAX handler which validates against a DTD instance.  + The document's root element must be named <tt>root</tt>.  + Used with <tt>dom:map-document</tt>, this validates a document + object as if by re-reading it with a validating parser, except + that declarations recorded in the document instance are completely + ignored.<br/> + Example: + </p> + <pre>(let ((d (parse-file "~/test.xml" (cxml-dom:make-dom-builder))) + (x (parse-dtd-file "~/test.dtd"))) + (dom:map-document (cxml:make-validator x #"foo") d))</pre> + + <p> + <div class="def">Class CXML:BROADCAST-HANDLER ()</div> + <div class="def">Accessor CXML:BROADCAST-HANDLER-HANDLERS</div> + <div class="def">Function CXML:MAKE-BROADCAST-HANDLER (&rest handlers)</div> + <tt>broadcast-handler</tt> is a SAX handler which passes every event it + receives on to each of several chained handlers, somewhat similar + to the way a <tt>broadcast-stream</tt> works. + </p> + <p> + You can subclass <tt>broadcast-stream</tt> to modify the events + before they are being passed on. Define methods on your handler + class for the events to be modified. All other events will pass + through to the chained handlers unmodified. + </p> + <p> + Broadcast handler functions return the result of calling the event + function on the <i>last</i> handler in the list. In particular, + the overall result from <tt>sax:end-document</tt> will be ignored + for all other handlers. + </p> + + <p> + <div class="def">Class CXML:SAX-PROXY (broadcast-handler)</div> + <div class="def">Accessor CXML:PROXY-CHAINED-HANDLER</div> + <tt>sax-proxy</tt> is a subclass of <tt>broadcast-handler</tt> + which sends events to exactly one chained handler. This class is + still included for compatibility with older versions of + CXML which did not include the more + general <tt>broadcast-handler</tt> yet, but has been retrofitted + as a subclass of the latter. + </p> + + <p> + <div class="def">Accessor CXML:MAKE-NAMESPACE-NORMALIZER (next-handler)</div> + </p> + <p> + Return a SAX handler that performs <a + href="http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/namespaces-algorith…">DOM + 3-style namespace normalization</a> on attribute lists in + <tt>start-element</tt> events before passing them on the next + handler. + </p> + <p> + <div class="def">Function CXML:MAKE-WHITESPACE-NORMALIZER (chained-handler &optional dtd)</div> + Return a SAX handler which removes whitespace from elements that + have <em>element content</em> and have not been declared to + preserve space using an xml:space attribute. + </p> + <p>Example:</p> + <pre>(cxml:parse-file "example.xml" + (cxml:make-whitespace-normalizer (cxml-dom:make-dom-builder)) + :validate t)</pre> + <p>Example input:</p> + <pre><!DOCTYPE test [ +<!ELEMENT test (foo,bar*)> +<!ATTLIST test a CDATA #IMPLIED> +<!ELEMENT foo #PCDATA> +<!ELEMENT bar (foo?)> +<!ATTLIST bar xml:space (default|preserve) "default"> +]> +<test a='b'> + <foo> </foo> + <bar> </bar> + <bar xml:space="preserve"> </bar> +</test> +</pre> + <p>Example result:</p> + <pre><test a="b"><foo> </foo><bar></bar><bar xml:space="preserve"> </bar></test></pre> + + <a name="rods"/> + <h3>Recoders</h3> + <p> + Recoders are a mechanism used by CXML internally on Lisp implementations + without Unicode support to recode UTF-16 vectors (rods) of + integers (runes) into UTF-8 strings. + </p> + <p> + User code does not usually need to deal with recoders in current + versions of CXML. + </p> + <p> + <div class="def">Function CXML:MAKE-RECODER (chained-handler recoder-fn)</div> + Return a SAX handler which passes all events on to + <tt>chained-handler</tt> after converting all strings and rods + using <tt>recoder-fn</tt>, a function of one argument. + </p> + + <a name="dtdcache"/> + <h3>Caching of DTD Objects</h3> + <p> + To avoid spending time parsing the same DTD over and over again, + CXML can cache DTD objects. The parser consults + <tt>cxml:*dtd-cache*</tt> whenever it is looking for an external + subset in a document which does not have an internal subset and + uses the cached DTD instance if one is present in the cache for + the System ID in question. + </p> + <p> + Note that DTDs do not expire from the cache automatically. + (Future versions of CXML might introduce automatic checks for + outdated DTDs.) + </p> + <p> + <div class="def">Variable CXML:*DTD-CACHE*</div> + The DTD cache object consulted by the parser when it needs a DTD. + </p> + <p> + <div class="def">Function CXML:MAKE-DTD-CACHE ()</div> + Return a new, empty DTD cache object. + </p> + <p> + <div class="def">Variable CXML:*CACHE-ALL-DTDS*</div> + If true, instructs the parser to enter all DTDs that could have + been cached into <tt>*dtd-cache*</tt> if they were not cached + already. Defaults to <tt>nil</tt>. + </p> + <p> + <div class="def">Reader CXML:GETDTD (uri dtd-cache)</div> + Return a cached instance of the DTD at <tt>uri</tt>, if present in + the cache, or <tt>nil</tt>. + </p> + <p> + <div class="def">Writer CXML:GETDTD (uri dtd-cache)</div> + Enter a new value for <tt>uri</tt> into <tt>dtd-cache</tt>. + </p> + <p> + <div class="def">Function CXML:REMDTD (uri dtd-cache)</div> + Ensure that no DTD is recorded for <tt>uri</tt> in the cache and + return true if such a DTD was present. + </p> + <p> + <div class="def">Function CXML:CLEAR-DTD-CACHE (dtd-cache)</div> + Remove all entries from <tt>dtd-cache</tt>. + </p> + <p> + <em>fixme:</em> thread-safety + </p> + + <a name="saxparser"/> + <h3>Location information</h3> + <p> + <div class="def">Class SAX:SAX-PARSER ()</div> + A class providing location information through an + implementation-specific subclass. Parsers will use + <tt>sax:register-sax-parser</tt> to pass their parser instance to + the handler. The easiest way to receive sax parsers instances is + to inherit from sax-parser-mixin when defining a sax handler. + </p> + <p> + <div class="def">Class SAX:SAX-PARSER-MIXIN ()</div> + A mixin for sax handler classes that records the sax handler + object for use with the following functions. Trampoline methods + are provided that allow those functions to be called directly on + the sax-parser-mixin. + </p> + <p> + <div class="def">Function SAX:SAX-HANDLER (sax-handler-mixin) => sax-handler</div> + Return the sax-parser instance recorded by this handler, or NIL. + </p> + <p> + <div class="def">Function SAX:LINE-NUMBER (sax-parser)</div> + Return an approximation of the current line number, or NIL. + </p> + <p> + <div class="def">Function SAX:COLUMN-NUMBER (sax-parser)</div> + Return an approximation of the current column number, or NIL. + </p> + <p> + <div class="def">Function SAX:SYSTEM-ID (sax-parser)</div> + Return the URI of the document being parsed. This is either the + main document, or the entity's system ID while contents of a parsed + general external entity are being processed. + </p> + <p> + <div class="def">Function SAX:XML-BASE (sax-parser)</div> + Return the [Base URI] of the current element. This URI can differ from + the value returned by <tt>sax:system-id</tt> if xml:base + attributes are present. + </p> + + <a name="catalogs"/> + <h3>XML Catalogs</h3> + <p> + External entities (for example, DTDs) are referred to using their + Public and System IDs. Usually the System ID, a URI, is used to + locate the entity. CXML itself handles only file://-URIs, but + many System IDs in practical use are http://-URIs. There are two + different mechanims applications can use to allow CXML to locate + entities using arbitrary Public ID or System ID: + </p> + <ul> + <li> + User-defined entity resolvers can be used to open entities using + arbitrary protocols. For example, an entity resolver could + handle all System-IDs with the <tt>http</tt> scheme using some + HTTP library. Refer to the description of the + <tt>entity-resolver</tt> keyword argument to parser functions (see <a + href="#parser"><tt>cxml:parse-file</tt></a>) to more + information on entity resolvers. + </li> + <li> + XML Catalogs are (local) tables in XML syntax which map External + IDs to alternative System IDs. If, say, the xhtml DTD is + present in the local file system and the local copy has been + registered with the XML catalog, CXML will use the local copy of + the DTD instead of trying to open the version available using HTTP. + </li> + </ul> + <p> + This section describes XML Catalogs, the second solution. CXML + implements <a + href="http://www.oasis-open.org/committees/entity/spec.html">Oasis + XML Catalogs</a>. + </p> + <p> + <div class="def">Variable CXML:*CATALOG*</div> + The XML Catalog object consulted by the parser before trying to + open an entity. Initially <tt>nil</tt>. + </p> + <p> + <div class="def">Variable CXML:*PREFER*</div> + The default "prefer" mode from the Catalog specification, one + of <tt>:public</tt> or <tt>:system</tt>. Defaults + to <tt>:public</tt>. + </p> + <p> + <div class="def">Function CXML:MAKE-CATALOG (&optional uris)</div> + Return a catalog object for the catalog files specified. + </p> + <p> + <div class="def">Function CXML:RESOLVE-URI (uri catalog)</div> + Look up <tt>uri</tt> in <tt>catalog</tt> and return the + resulting URI, or <tt>nil</tt> if no match was found. + </p> + <p> + <div class="def">Function CXML:RESOLVE-EXTID (publicid systemid catalog)</div> + Look up the External ID (<tt>publicid</tt>, <tt>systemid</tt>) + in <tt>catalog</tt> and return the resulting URI, or <tt>nil</tt> + if no match was found. + </p> + <p> + Example: + </p> + <pre>* (setf cxml:*catalog* nil) +* (cxml:parse-file "test.xhtml" nil) +=> Error: URI scheme :HTTP not supported + +* (setf cxml:*catalog* (cxml:make-catalog)) +* (cxml:parse-file "test.xhtml" nil) +;; no error! +NIL</pre> + <p> + Note that parsed catalog files are cached in the catalog object. + Catalog files cached do not expire automatically. To ensure that + all catalog files are parsed again, create a new catalog object. + </p> + + <a name="sax"/> + <h2>SAX Interface</h2> + <p> + A SAX handler is an arbitrary objects that implements some of the + generic functions in the SAX package.  Note that no default + handler class is necessary, because all generic functions have default + methods which do nothing.  SAX functions are: + <div class="def">Function SAX:START-DOCUMENT (handler)</div> + <div class="def">Function SAX:END-DOCUMENT (handler)</div> + <br/> + <div class="def">Function SAX:START-ELEMENT (handler namespace-uri local-name qname attributes)</div> + <div class="def">Function SAX:END-ELEMENT (handler namespace-uri local-name qname)</div> + <div class="def">Function SAX:START-PREFIX-MAPPING (handler prefix uri)</div> + <div class="def">Function SAX:END-PREFIX-MAPPING (handler prefix)</div> + <div class="def">Function SAX:PROCESSING-INSTRUCTION (handler target data)</div> + <div class="def">Function SAX:COMMENT (handler data)</div> + <div class="def">Function SAX:START-CDATA (handler)</div> + <div class="def">Function SAX:END-CDATA (handler)</div> + <div class="def">Function SAX:CHARACTERS (handler data)</div> + <br/> + <div class="def">Function SAX:START-DTD (handler name public-id system-id)</div> + <div class="def">Function SAX:END-DTD (handler)</div> + <div class="def">Function SAX:START-INTERNAL-SUBSET (handler)</div> + <div class="def">Function SAX:END-INTERNAL-SUBSET (handler)</div> + <div class="def">Function SAX:UNPARSED-ENTITY-DECLARATION (handler name public-id system-id notation-name)</div> + <div class="def">Function SAX:EXTERNAL-ENTITY-DECLARATION (handler kind name public-id system-id)</div> + <div class="def">Function SAX:INTERNAL-ENTITY-DECLARATION (handler kind name value)</div> + <div class="def">Function SAX:NOTATION-DECLARATION (handler name public-id system-id)</div> + <div class="def">Function SAX:ELEMENT-DECLARATION (handler name model)</div> + <div class="def">Function SAX:ATTRIBUTE-DECLARATION (handler ename aname type default)</div> + <br/> + <div class="def">Accessor SAX:ATTRIBUTE-PREFIX (attribute)</div> + <div class="def">Accessor SAX:ATTRIBUTE-NAMESPACE-URI (attribute)</div> + <div class="def">Accessor SAX:ATTRIBUTE-LOCAL-NAME (attribute)</div> + <div class="def">Accessor SAX:ATTRIBUTE-QNAME (attribute)</div> + <div class="def">Accessor SAX:ATTRIBUTE-SPECIFIED-P (attribute)</div> + <div class="def">Accessor SAX:ATTRIBUTE-VALUE (attribute)</div> + <br/> + <div class="def">Function SAX:FIND-ATTRIBUTE (qname attributes)</div> + <div class="def">Function SAX:FIND-ATTRIBUTE-NS (uri lname attributes)</div> + </p> + <p> + The entity declaration methods are similar to Java SAX + definitions, but parameter entities are distinguished from + general entities not by a <tt>%</tt> prefix to the name, but by + the <tt>kind</tt> argument, either <tt>:parameter</tt> or + <tt>:general</tt>. + </p> + <p> + The arguments to <tt>sax:element-declaration</tt> and + <tt>sax:attribute-declaration</tt> differ significantly from their + Java counterparts. + </p> + <p> + <i>fixme</i>: For more information on these functions refer to the docstrings. + </p> +</documentation> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/xmls-compat.html =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/xmls-compat.html 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/xmls-compat.html 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,140 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"> +<html> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> +<title>CXML XMLS Compatibility</title> +<link rel="stylesheet" type="text/css" href="cxml.css"> +</head> +<body> +<div class="sidebar"> +<div class="sidebar-title"><a href="index.html">Closure XML</a></div> +<div class="sidebar-main"><ul class="main"> +<li> +<a href="installation.html">Installing Closure XML</a><ul class="sub"> +<li><a href="installation.html#download"><b>Download</b></a></li> +<li><a href="installation.html#implementations">Implementation-specific notes</a></li> +<li><a href="installation.html#compilation">Compilation</a></li> +<li><a href="installation.html#tests">Tests</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li> +<li> +<a href="sax.html">SAX parsing and serialization</a><ul class="sub"> +<li><a href="sax.html#parser">Parsing and Validating</a></li> +<li><a href="sax.html#serialization">Serialization</a></li> +<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li> +<li><a href="sax.html#rods">Recoders</a></li> +<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li> +<li><a href="sax.html#catalogs">XML Catalogs</a></li> +<li><a href="sax.html#sax">SAX Interface</a></li> +</ul> +</li> +<li> +<a href="klacks.html">Klacks parser</a><ul class="sub"> +<li><a href="klacks.html#sources">Parsing incrementally</a></li> +<li><a href="klacks.html#convenience">Convenience functions</a></li> +<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li> +<li><a href="klacks.html#locator">Location information</a></li> +<li><a href="klacks.html#klacksax">Examples</a></li> +</ul> +</li> +<li> +<a href="dom.html">DOM implementation</a><ul class="sub"> +<li><a href="dom.html#parser">Parsing with the DOM builder</a></li> +<li><a href="dom.html#serialization">Serialization</a></li> +<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li> +</ul> +</li> +<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li> +</ul></div> +</div> + <h1>XMLS Builder</h1> + <p> + Like other XML parsers written in Lisp, CXML can work with + documents represented as list structures. The specific model + implemented by cxml is compatible with the <a href="http://common-lisp.net/project/xmls/">xmls parser</a>. Xmls + list structures are a simpler and faster alternative to full DOM + document trees. They also serve as an example showing how to + implement user-defined document models as an independent layer + over the the base parser (c.f. <tt>xml/xmls-compat.lisp</tt> in + the cxml distribution). However, note that the list structures do + not include all information available in DOM documents + (notably, things like <tt>dom:parent-node</tt>) and are + sometimes more difficult to work with because of that since many + DOM functions cannot be implemented on them. + </p> + <p> + <b>New namespace handling:</b> + XMLS compatibility is not <i>bug-for-bug</i>-compatible with + XMLS any more. There is now a mode using pairs of local name + and namespace URI, and a second mode using qualified names + only. The old behaviour using pairs of prefix and local names + was removed. + </p> + <p> + <strike> + fixme: It is unclear to me how namespaces are meant to + work in xmls, since xmls documentation differs from how xmls + actually works in current releases. Usually applications need to + know both the namespace prefix <em>and</em> the namespace URI. We + currently follow the xmls <em>implementation</em> and use the + namespace prefix instead of following its <em>documentation</em> which + shows the URI. We do not follow xmls in munging xmlns attribute + values. Attributes themselves have namespaces and it is not clear + to me how that works in xmls. + </strike> + </p> + <p> + <div class="def">Function CXML-XMLS:MAKE-XMLS-BUILDER (&key include-default-values include-namespace-uri)</div> + Create a SAX handler which builds XMLS list structures. + If <tt>include-default-values</tt> is true, default values for + attributes declared in a DTD are included as attributes in the + xmls output. <tt>include-default-values</tt> is true by default + and can be set to <tt>nil</tt> to suppress inclusion of default + values. + </p> + <p> + If <tt>include-namespace-uri</tt> is true (the default), node + names and attribute names are pairs of local name and namespace + URI. (Except for attributes without a namespace, which are named + using a string.) Otherwise, nodes and attributes are named by + their qualified name. + </p> + <p> + Example: + </p> + <pre>(cxml:parse-file "test.xml" (cxml-xmls:make-xmls-builder))</pre> + <p> + <div class="def">Function CXML-XMLS:MAP-NODE (handler node &key include-xmlns-attributes include-namespace-uri)</div> + Traverse an XMLS document/node and call SAX functions as if an XML + representation of the document were processed by a SAX parser. + </p> + <p> + Use this function to serialize XMLS data. For example, we could + define a replacement for <tt>xmls:write-xml</tt> like this: + </p> + <pre>(defun write-xml (stream node &key indent) + (let ((sink (cxml:make-character-stream-sink + stream :canonical nil :indentation indent))) + (cxml-xmls:map-node sink node)))</pre> + <p> + <div class="def">Function CXML-XMLS:MAKE-NODE (&key name ns attrs + children) => xmls node</div> + Build a list node of the form + (<em>name</em> ((<em>name</em> <em>value</em>)<em>*</em>) <em>child*</em>). + </p> + <p> + The node list's <tt>car</tt> can also be a cons of local <tt>name</tt> + and namespace prefix <tt>ns</tt>. + </p> + <p> + <div class="def">Accessor CXML-XMLS:NODE-NAME (node)</div> + <div class="def">Accessor CXML-XMLS:NODE-NS (node)</div> + <div class="def">Accessor CXML-XMLS:NODE-ATTRS (node)</div> + <div class="def">Accessor CXML-XMLS:NODE-CHILDREN (node)</div> + Accessors for xmls node data. + </p> + <p> + </p> +</body> +</html> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/xmls-compat.xml =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/xmls-compat.xml 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/doc/xmls-compat.xml 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,91 @@ +<documentation title="CXML XMLS Compatibility"> + <h1>XMLS Builder</h1> + <p> + Like other XML parsers written in Lisp, CXML can work with + documents represented as list structures. The specific model + implemented by cxml is compatible with the <a + href="http://common-lisp.net/project/xmls/">xmls parser</a>. Xmls + list structures are a simpler and faster alternative to full DOM + document trees. They also serve as an example showing how to + implement user-defined document models as an independent layer + over the the base parser (c.f. <tt>xml/xmls-compat.lisp</tt> in + the cxml distribution). However, note that the list structures do + not include all information available in DOM documents + (notably, things like <tt>dom:parent-node</tt>) and are + sometimes more difficult to work with because of that since many + DOM functions cannot be implemented on them. + </p> + <p> + <b>New namespace handling:</b> + XMLS compatibility is not <i>bug-for-bug</i>-compatible with + XMLS any more. There is now a mode using pairs of local name + and namespace URI, and a second mode using qualified names + only. The old behaviour using pairs of prefix and local names + was removed. + </p> + <p> + <strike> + fixme: It is unclear to me how namespaces are meant to + work in xmls, since xmls documentation differs from how xmls + actually works in current releases. Usually applications need to + know both the namespace prefix <em>and</em> the namespace URI. We + currently follow the xmls <em>implementation</em> and use the + namespace prefix instead of following its <em>documentation</em> which + shows the URI. We do not follow xmls in munging xmlns attribute + values. Attributes themselves have namespaces and it is not clear + to me how that works in xmls. + </strike> + </p> + <p> + <div class="def">Function CXML-XMLS:MAKE-XMLS-BUILDER (&key include-default-values include-namespace-uri)</div> + Create a SAX handler which builds XMLS list structures.  + If <tt>include-default-values</tt> is true, default values for + attributes declared in a DTD are included as attributes in the + xmls output. <tt>include-default-values</tt> is true by default + and can be set to <tt>nil</tt> to suppress inclusion of default + values. + </p> + <p> + If <tt>include-namespace-uri</tt> is true (the default), node + names and attribute names are pairs of local name and namespace + URI. (Except for attributes without a namespace, which are named + using a string.) Otherwise, nodes and attributes are named by + their qualified name. + </p> + <p> + Example: + </p> + <pre>(cxml:parse-file "test.xml" (cxml-xmls:make-xmls-builder))</pre> + <p> + <div class="def">Function CXML-XMLS:MAP-NODE (handler node &key include-xmlns-attributes include-namespace-uri)</div> + Traverse an XMLS document/node and call SAX functions as if an XML + representation of the document were processed by a SAX parser. + </p> + <p> + Use this function to serialize XMLS data. For example, we could + define a replacement for <tt>xmls:write-xml</tt> like this: + </p> + <pre>(defun write-xml (stream node &key indent) + (let ((sink (cxml:make-character-stream-sink + stream :canonical nil :indentation indent))) + (cxml-xmls:map-node sink node)))</pre> + <p> + <div class="def">Function CXML-XMLS:MAKE-NODE (&key name ns attrs + children) => xmls node</div> + Build a list node of the form + (<em>name</em> ((<em>name</em> <em>value</em>)<em>*</em>) <em>child*</em>). + </p> + <p> + The node list's <tt>car</tt> can also be a cons of local <tt>name</tt> + and namespace prefix <tt>ns</tt>. + </p> + <p> + <div class="def">Accessor CXML-XMLS:NODE-NAME (node)</div> + <div class="def">Accessor CXML-XMLS:NODE-NS (node)</div> + <div class="def">Accessor CXML-XMLS:NODE-ATTRS (node)</div> + <div class="def">Accessor CXML-XMLS:NODE-CHILDREN (node)</div> + Accessors for xmls node data. + </p> + <p> + </p> +</documentation> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/documentation.css =================================================================== Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/Entries 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/Entries 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,5 @@ +/dom-builder.lisp/1.13/Sun Jul 22 19:59:26 2007// +/dom-impl.lisp/1.42/Sun Sep 10 14:52:44 2006// +/dom-sax.lisp/1.7/Sun Aug 20 14:59:34 2006// +/package.lisp/1.6/Sun Aug 20 12:19:01 2006// +D Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/Repository 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/Repository 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +cxml/dom Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/Root 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/CVS/Root 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +:ext:dlichteblau@common-lisp.net:/project/cxml/cvsroot Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/dom-builder.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/dom-builder.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/dom-builder.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,208 @@ +;;;; dom-builder.lisp -- DOM-building SAX handler +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;;; Author: Henrik Motakef <hmot(a)henrik-motakef.de> +;;;; Author: David Lichteblau <david(a)lichteblau.com> +;;;; Author: knowledgeTools Int. GmbH + +#-cxml-system::utf8dom-file +(in-package :rune-dom) + +#+cxml-system::utf8dom-file +(in-package :utf8-dom) + + +(defclass dom-builder () + ((document :initform nil :accessor document) + (element-stack :initform '() :accessor element-stack) + (internal-subset :accessor internal-subset))) + +(defun make-dom-builder () + (make-instance 'dom-builder)) + +(defun fast-push (new-element vector) + (vector-push-extend new-element vector (max 1 (array-dimension vector 0)))) + +(defmethod sax:start-document ((handler dom-builder)) + (when (and sax:*namespace-processing* + (not (and sax:*include-xmlns-attributes* + sax:*use-xmlns-namespace*))) + (error "SAX configuration is incompatible with DOM: *namespace-processing* is activated, but *include-xmlns-attributes* or *use-xmlns-namespace* are not")) + (let ((document (make-instance 'document))) + (setf (slot-value document 'owner) nil + (slot-value document 'doc-type) nil) + (setf (document handler) document) + (push document (element-stack handler)))) + +;; fixme +(defmethod sax::dtd ((handler dom-builder) dtd) + (setf (slot-value (document handler) 'dtd) dtd)) + +(defmethod sax:end-document ((handler dom-builder)) + (let ((doctype (dom:doctype (document handler)))) + (when doctype + (setf (slot-value (dom:entities doctype) 'read-only-p) t) + (setf (slot-value (dom:notations doctype) 'read-only-p) t))) + (document handler)) + +(defmethod sax:entity-resolver ((handler dom-builder) resolver) + (setf (slot-value (document handler) 'entity-resolver) resolver)) + +(defmethod sax:start-dtd ((handler dom-builder) name publicid systemid) + (let* ((document (document handler)) + (doctype (%create-document-type name publicid systemid))) + (setf (slot-value doctype 'owner) document + (slot-value (dom:notations doctype) 'owner) document + (slot-value (dom:entities doctype) 'owner) document + (slot-value document 'doc-type) doctype))) + +(defmethod sax:start-internal-subset ((handler dom-builder)) + (setf (internal-subset handler) nil)) + +(defmethod sax:end-internal-subset ((handler dom-builder)) + (setf (dom::%internal-subset (slot-value (document handler) 'doc-type)) + (nreverse (internal-subset handler))) + (slot-makunbound handler 'internal-subset)) + +(macrolet ((defhandler (name &rest args) + `(defmethod ,name ((handler dom-builder) ,@args) + (when (slot-boundp handler 'internal-subset) + (push (list ',name ,@args) (internal-subset handler)))))) + (defhandler sax:unparsed-entity-declaration + name public-id system-id notation-name) + (defhandler sax:external-entity-declaration + kind name public-id system-id) + (defhandler sax:internal-entity-declaration + kind name value) + (defhandler sax:notation-declaration + name public-id system-id) + (defhandler sax:element-declaration + name model) + (defhandler sax:attribute-declaration + element-name attribute-name type default)) + +(defmethod sax:start-element + ((handler dom-builder) namespace-uri local-name qname attributes) + (check-type qname rod) ;catch recoder/builder mismatch + (with-slots (document element-stack) handler + (let* ((nsp sax:*namespace-processing*) + (element (make-instance 'element + :tag-name qname + :owner document + :namespace-uri (when nsp namespace-uri) + :local-name (when nsp local-name) + :prefix (%rod (when nsp (cxml::split-qname (real-rod qname)))))) + (parent (car element-stack)) + (anodes '())) + (dolist (attr attributes) + (let ((anode + (if nsp + (dom:create-attribute-ns document + (sax:attribute-namespace-uri attr) + (sax:attribute-qname attr)) + (dom:create-attribute document (sax:attribute-qname attr)))) + (text + (dom:create-text-node document (sax:attribute-value attr)))) + (setf (slot-value anode 'specified-p) + (sax:attribute-specified-p attr)) + (setf (slot-value anode 'owner-element) element) + (dom:append-child anode text) + (push anode anodes))) + (setf (slot-value element 'parent) parent) + (fast-push element (slot-value parent 'children)) + (let ((map + (make-instance 'attribute-node-map + :items anodes + :element-type :attribute + :element element + :owner document))) + (setf (slot-value element 'attributes) map) + (dolist (anode anodes) + (setf (slot-value anode 'map) map))) + (push element element-stack)))) + +(defmethod sax:end-element ((handler dom-builder) namespace-uri local-name qname) + (declare (ignore namespace-uri local-name qname)) + (pop (element-stack handler))) + +(defmethod sax:characters ((handler dom-builder) data) + (with-slots (document element-stack) handler + (let* ((parent (car element-stack)) + (last-child (dom:last-child parent))) + (cond + ((eq (dom:node-type parent) :cdata-section) + (setf (dom:data parent) data)) + ((and last-child (eq (dom:node-type last-child) :text)) + ;; um entities herum wird SAX:CHARACTERS mehrfach aufgerufen fuer + ;; den gleichen Textknoten. Hier muessen wir den bestehenden Knoten + ;; erweitern, sonst ist das Dokument nicht normalisiert. + ;; (XXX Oder sollte man besser den Parser entsprechend aendern?) + (dom:append-data last-child data)) + (t + (let ((node (dom:create-text-node document data))) + (setf (slot-value node 'parent) parent) + (fast-push node (slot-value (car element-stack) 'children)))))))) + +(defmethod sax:start-cdata ((handler dom-builder)) + (with-slots (document element-stack) handler + (let ((node (dom:create-cdata-section document #"")) + (parent (car element-stack))) + (setf (slot-value node 'parent) parent) + (fast-push node (slot-value parent 'children)) + (push node element-stack)))) + +(defmethod sax:end-cdata ((handler dom-builder)) + (let ((node (pop (slot-value handler 'element-stack)))) + (assert (eq (dom:node-type node) :cdata-section)))) + +(defmethod sax:processing-instruction ((handler dom-builder) target data) + (with-slots (document element-stack) handler + (let ((node (dom:create-processing-instruction document target data)) + (parent (car element-stack))) + (setf (slot-value node 'parent) parent) + (fast-push node (slot-value (car element-stack) 'children))))) + +(defmethod sax:comment ((handler dom-builder) data) + (with-slots (document element-stack) handler + (let ((node (dom:create-comment document data)) + (parent (car element-stack))) + (setf (slot-value node 'parent) parent) + (fast-push node (slot-value (car element-stack) 'children))))) + +(defmethod sax:unparsed-entity-declaration + ((handler dom-builder) name public-id system-id notation-name) + (set-entity handler name public-id system-id notation-name)) + +(defmethod sax:external-entity-declaration + ((handler dom-builder) kind name public-id system-id) + (ecase kind + (:general (set-entity handler name public-id system-id nil)) + (:parameter))) + +(defmethod sax:internal-entity-declaration + ((handler dom-builder) kind name value) + (declare (ignore value)) + (ecase kind + (:general (set-entity handler name nil nil nil)) + (:parameter))) + +(defun set-entity (handler name pid sid notation) + (dom:set-named-item (dom:entities (dom:doctype (document handler))) + (make-instance 'entity + :owner (document handler) + :name name + :public-id pid + :system-id sid + :notation-name notation))) + +(defmethod sax:notation-declaration + ((handler dom-builder) name public-id system-id) + (dom:set-named-item (dom:notations (dom:doctype (document handler))) + (make-instance 'notation + :owner (document handler) + :name name + :public-id public-id + :system-id system-id))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/dom-impl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/dom-impl.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/dom-impl.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,1478 @@ +;;;; dom-impl.lisp -- Implementation of DOM 1 Core -*- package: rune-dom -*- +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;;; Author: David Lichteblau <david(a)lichteblau.com> +;;;; Author: knowledgeTools Int. GmbH + +#-cxml-system::utf8dom-file +(defpackage :rune-dom + (:use :cl :runes) + #+rune-is-character (:nicknames :cxml-dom) + (:export #:implementation #:make-dom-builder #:create-document)) + +#+cxml-system::utf8dom-file +(defpackage :utf8-dom + (:use :cl :utf8-runes) + (:nicknames :cxml-dom) + (:export #:implementation #:make-dom-builder #:create-document)) + +#-cxml-system::utf8dom-file +(in-package :rune-dom) + +#+cxml-system::utf8dom-file +(in-package :utf8-dom) + + +;; Classes + +(define-condition dom-exception (error) + ((key :initarg :key :reader dom-exception-key) + (string :initarg :string :reader dom-exception-string) + (arguments :initarg :arguments :reader dom-exception-arguments)) + (:report + (lambda (c s) + (format s "~A (~D):~%~?" + (dom-exception-key c) + (dom:code c) + (dom-exception-string c) + (dom-exception-arguments c))))) + +(defclass node (dom:node) + ((parent :initarg :parent :initform nil) + (children :initarg :children :initform (make-node-list)) + (owner :initarg :owner :initform nil) + (read-only-p :initform nil :reader read-only-p) + (map :initform nil))) + +(defmethod dom:prefix ((node node)) nil) +(defmethod dom:local-name ((node node)) nil) +(defmethod dom:namespace-uri ((node node)) nil) + +(defclass namespace-mixin () + ((prefix :initarg :prefix :reader dom:prefix) + (local-name :initarg :local-name :reader dom:local-name) + (namespace-uri :initarg :namespace-uri :reader dom:namespace-uri))) + +(defmethod (setf dom:prefix) (newval (node namespace-mixin)) + (assert-writeable node) + (when newval + (safe-split-qname (concatenate 'rod newval #":foo") + (dom:namespace-uri node))) + (setf (slot-value node 'prefix) newval)) + +(defclass document (node dom:document) + ((doc-type :initarg :doc-type :reader dom:doctype) + (dtd :initform nil :reader dtd) + (entity-resolver :initform nil))) + +(defclass document-fragment (node dom:document-fragment) + ()) + +(defclass character-data (node dom:character-data) + ((value :initarg :data :reader dom:data))) + +(defclass attribute (namespace-mixin node dom:attr) + ((name :initarg :name :reader dom:name) + (owner-element :initarg :owner-element :reader dom:owner-element) + (specified-p :initarg :specified-p :reader dom:specified))) + +(defmethod (setf dom:prefix) :before (newval (node attribute)) + (when (rod= (dom:node-name node) #"xmlns") + (dom-error :NAMESPACE_ERR "must not change xmlns attribute prefix"))) + +(defmethod (setf dom:prefix) :after (newval (node attribute)) + (setf (slot-value node 'name) + (concatenate 'rod newval #":" (dom:local-name node)))) + +(defmethod print-object ((object attribute) stream) + (print-unreadable-object (object stream :type t :identity t) + (format stream "~A=~S" + (rod-string (dom:name object)) + (rod-string (dom:value object))))) + +(defclass element (namespace-mixin node dom:element) + ((tag-name :initarg :tag-name :reader dom:tag-name) + (attributes :initarg :attributes :reader dom:attributes))) + +(defmethod (setf dom:prefix) :after (newval (node element)) + (setf (slot-value node 'tag-name) + (concatenate 'rod newval #":" (dom:local-name node)))) + +(defmethod print-object ((object element) stream) + (print-unreadable-object (object stream :type t :identity t) + (princ (rod-string (dom:tag-name object)) stream))) + +(defclass text (character-data dom:text) + ()) + +(defclass comment (character-data dom:comment) + ()) + +(defclass cdata-section (text dom:cdata-section) + ()) + +(defclass document-type (node dom:document-type) + ((name :initarg :name :reader dom:name) + (public-id :initarg :public-id :reader dom:public-id) + (system-id :initarg :system-id :reader dom:system-id) + (entities :initarg :entities :reader dom:entities) + (notations :initarg :notations :reader dom:notations) + (dom::%internal-subset :accessor dom::%internal-subset))) + +(defclass notation (node dom:notation) + ((name :initarg :name :reader dom:name) + (public-id :initarg :public-id :reader dom:public-id) + (system-id :initarg :system-id :reader dom:system-id))) + +(defclass entity (node dom:entity) + ((name :initarg :name :reader dom:name) + (public-id :initarg :public-id :reader dom:public-id) + (system-id :initarg :system-id :reader dom:system-id) + (notation-name :initarg :notation-name :reader dom:notation-name))) + +(defclass entity-reference (node dom:entity-reference) + ((name :initarg :name :reader dom:name))) + +(defclass processing-instruction (node dom:processing-instruction) + ((target :initarg :target :reader dom:target) + (data :initarg :data :reader dom:data))) + +(defclass named-node-map (dom:named-node-map) + ((items :initarg :items :reader dom:items + :initform nil) + (owner :initarg :owner :reader dom:owner-document) + (read-only-p :initform nil :reader read-only-p) + (element-type :initarg :element-type))) + +(defclass attribute-node-map (named-node-map) + ((element :initarg :element))) + + +;;; Implementation + +(defun %rod (x) + (etypecase x + (null x) + (rod x) + #+cxml-system::utf8dom-file (runes::rod (cxml::rod-to-utf8-string x)) + (string (string-rod x)) + (vector x))) + +#-cxml-system::utf8dom-file +(defun real-rod (x) + (%rod x)) + +#+cxml-system::utf8dom-file +(defun real-rod (x) + (etypecase x + (null x) + (runes::rod x) + (string (cxml::utf8-string-to-rod x)))) + +(defun valid-name-p (x) + (cxml::valid-name-p (real-rod x))) + +(defun assert-writeable (node) + (when (read-only-p node) + (dom-error :NO_MODIFICATION_ALLOWED_ERR "~S is marked read-only." node))) + +(defun dom:map-node-list (fn nodelist) + (dotimes (i (dom:length nodelist)) + (funcall fn (dom:item nodelist i)))) + +(defmacro dom:do-node-list ((var nodelist &optional resultform) &body body) + `(block nil + (dom:map-node-list (lambda (,var) ,@body) ,nodelist) + ,resultform)) + +(defun dom:map-node-map (fn node-map) + (with-slots (items) node-map + (mapc fn items))) + +(defmacro dom:do-node-map ((var node-map &optional resultform) &body body) + `(block nil + (dom:map-node-map (lambda (,var) ,@body) ,node-map) + ,resultform)) + +(defmacro dovector ((var vector &optional resultform) &body body) + `(loop + for ,var across ,vector do (progn ,@body) + ,@(when resultform `(finally (return ,resultform))))) + +(defun move (from to from-start to-start length) + ;; like (setf (subseq to to-start (+ to-start length)) + ;; (subseq from from-start (+ from-start length))) + ;; but without creating the garbage. + ;; Also, this is using AREF not ELT so that fill-pointers are ignored. + (if (< to-start from-start) + (loop + repeat length + for i from from-start + for j from to-start + do (setf (aref to j) (aref from i))) + (loop + repeat length + for i downfrom (+ from-start length -1) + for j downfrom (+ to-start length -1) + do (setf (aref to j) (aref from i))))) + +(defun adjust-vector-exponentially (vector new-dimension set-fill-pointer-p) + (let ((d (array-dimension vector 0))) + (when (< d new-dimension) + (loop + do (setf d (* 2 d)) + while (< d new-dimension)) + (adjust-array vector d)) + (when set-fill-pointer-p + (setf (fill-pointer vector) new-dimension)))) + +(defun make-space (vector &optional (n 1)) + (adjust-vector-exponentially vector (+ (length vector) n) nil)) + +(defun extension (vector) + (max (array-dimension vector 0) 1)) + +;; dom-exception + +(defun dom-error (key fmt &rest args) + (error 'dom-exception :key key :string fmt :arguments args)) + +(defmethod dom:code ((self dom-exception)) + (ecase (dom-exception-key self) + (:INDEX_SIZE_ERR 1) + (:DOMSTRING_SIZE_ERR 2) + (:HIERARCHY_REQUEST_ERR 3) + (:WRONG_DOCUMENT_ERR 4) + (:INVALID_CHARACTER_ERR 5) + (:NO_DATA_ALLOWED_ERR 6) + (:NO_MODIFICATION_ALLOWED_ERR 7) + (:NOT_FOUND_ERR 8) + (:NOT_SUPPORTED_ERR 9) + (:INUSE_ATTRIBUTE_ERR 10) + (:INVALID_STATE_ERR 11) + (:SYNTAX_ERR 12) + (:INVALID_MODIFICATION_ERR 13) + (:NAMESPACE_ERR 14) + (:INVALID_ACCESS_ERR 15))) + +;; dom-implementation protocol + +(defmethod dom:has-feature ((factory (eql 'implementation)) feature version) + (and (or (string-equal (rod-string feature) "xml") + (string-equal (rod-string feature) "core")) + (or (zerop (length version)) + (string-equal (rod-string version) "1.0") + (string-equal (rod-string version) "2.0")))) + +(defun %create-document-type (name publicid systemid) + (make-instance 'document-type + :name name + :notations (make-instance 'named-node-map + :element-type :notation + :owner nil) + :entities (make-instance 'named-node-map + :element-type :entity + :owner nil) + :public-id publicid + :system-id systemid)) + +(defmethod dom:create-document-type + ((factory (eql 'implementation)) name publicid systemid) + (safe-split-qname name #"") + (let ((result (%create-document-type name publicid systemid))) + (setf (slot-value (dom:entities result) 'read-only-p) t) + (setf (slot-value (dom:notations result) 'read-only-p) t) + result)) + +(defmethod dom:create-document + ((factory (eql 'implementation)) uri qname doctype) + (let ((document (make-instance 'document))) + (setf (slot-value document 'owner) nil + (slot-value document 'doc-type) doctype) + (when doctype + (unless (typep doctype 'document-type) + (dom-error :WRONG_DOCUMENT_ERR + "doctype was created by a different dom implementation")) + (when (dom:owner-document doctype) + (dom-error :WRONG_DOCUMENT_ERR "doctype already in use")) + (setf (slot-value doctype 'owner) document + (slot-value (dom:notations doctype) 'owner) document + (slot-value (dom:entities doctype) 'owner) document)) + (when (or uri qname) + (dom:append-child document (dom:create-element-ns document uri qname))) + document)) + +;; document-fragment protocol +;; document protocol + +(defmethod dom:implementation ((document document)) + 'implementation) + +(defmethod dom:document-element ((document document)) + (dovector (k (dom:child-nodes document)) + (cond ((typep k 'element) + (return k))))) + +(defmethod dom:create-element ((document document) tag-name) + (setf tag-name (%rod tag-name)) + (unless (valid-name-p tag-name) + (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string tag-name))) + (let ((result (make-instance 'element + :tag-name tag-name + :namespace-uri nil + :local-name nil + :prefix nil + :owner document))) + (setf (slot-value result 'attributes) + (make-instance 'attribute-node-map + :element-type :attribute + :owner document + :element result)) + (add-default-attributes result) + result)) + +(defun safe-split-qname (qname uri) + (unless (valid-name-p qname) + (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string qname))) + (multiple-value-bind (prefix local-name) + (handler-case + (cxml::split-qname (real-rod qname)) + (cxml:well-formedness-violation (c) + (dom-error :NAMESPACE_ERR "~A" c))) + (setf local-name (%rod local-name)) + (when prefix + (setf prefix (%rod prefix)) + (unless uri + (dom-error :NAMESPACE_ERR "prefix specified but no namespace URI")) + (when (and (rod= prefix #"xml") + (not (rod= uri #"http://www.w3.org/XML/1998/namespace"))) + (dom-error :NAMESPACE_ERR "invalid uri for prefix `xml'")) + (when (and (rod= prefix #"xmlns") + (not (rod= uri #"http://www.w3.org/2000/xmlns/"))) + (dom-error :NAMESPACE_ERR "invalid uri for prefix `xmlns'"))) + (values prefix local-name))) + +(defmethod dom:create-element-ns ((document document) uri qname) + (setf qname (%rod qname)) + (multiple-value-bind (prefix local-name) + (safe-split-qname qname uri) + (let ((result (make-instance 'element + :tag-name qname + :namespace-uri uri + :local-name local-name + :prefix prefix + :owner document))) + (setf (slot-value result 'attributes) + (make-instance 'attribute-node-map + :element-type :attribute + :owner document + :element result)) + (add-default-attributes result) + result))) + +(defmethod dom:create-document-fragment ((document document)) + (make-instance 'document-fragment + :owner document)) + +(defmethod dom:create-text-node ((document document) data) + (setf data (%rod data)) + (make-instance 'text + :data data + :owner document)) + +(defmethod dom:create-comment ((document document) data) + (setf data (%rod data)) + (make-instance 'comment + :data data + :owner document)) + +(defmethod dom:create-cdata-section ((document document) data) + (setf data (%rod data)) + (make-instance 'cdata-section + :data data + :owner document)) + +(defmethod dom:create-processing-instruction ((document document) target data) + (setf target (%rod target)) + (setf data (%rod data)) + (unless (valid-name-p target) + (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string target))) + (make-instance 'processing-instruction + :owner document + :target target + :data data)) + +(defmethod dom:create-attribute ((document document) name) + (setf name (%rod name)) + (unless (valid-name-p name) + (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name))) + (make-instance 'attribute + :name name + :local-name nil + :prefix nil + :namespace-uri nil + :specified-p t + :owner-element nil + :owner document)) + +(defmethod dom:create-attribute-ns ((document document) uri qname) + (setf uri (%rod uri)) + (setf qname (%rod qname)) + (when (and (rod= qname #"xmlns") + (not (rod= uri #"http://www.w3.org/2000/xmlns/"))) + (dom-error :NAMESPACE_ERR "invalid uri for qname `xmlns'")) + (multiple-value-bind (prefix local-name) + (safe-split-qname qname uri) + (make-instance 'attribute + :name qname + :namespace-uri uri + :local-name local-name + :prefix prefix + :specified-p t + :owner-element nil + :owner document))) + +(defmethod dom:create-entity-reference ((document document) name) + (setf name (%rod name)) + (unless (valid-name-p name) + (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name))) + (make-instance 'entity-reference + :name name + :owner document)) + +(defmethod get-elements-by-tag-name-internal (node tag-name) + (setf tag-name (%rod tag-name)) + (let ((result (make-node-list)) + (wild-p (rod= tag-name #"*"))) + (labels ((walk (n) + (dovector (c (dom:child-nodes n)) + (when (dom:element-p c) + (when (or wild-p (rod= tag-name (dom:node-name c))) + (vector-push-extend c result (extension result))) + (walk c))))) + (walk node)) + result)) + +(defmethod get-elements-by-tag-name-internal-ns (node uri lname) + (setf uri (%rod uri)) + (setf lname (%rod lname)) + (let ((result (make-node-list)) + (wild-uri-p (rod= uri #"*")) + (wild-lname-p (rod= lname #"*"))) + (labels ((walk (n) + (dovector (c (dom:child-nodes n)) + (when (dom:element-p c) + (when (and (or wild-lname-p (rod= lname (dom:local-name c))) + (or wild-uri-p (rod= uri (dom:namespace-uri c)))) + (vector-push-extend c result (extension result))) + (walk c))))) + (walk node)) + result)) + +(defmethod dom:get-elements-by-tag-name ((document document) tag-name) + (get-elements-by-tag-name-internal document tag-name)) + +(defmethod dom:get-elements-by-tag-name-ns ((document document) uri lname) + (get-elements-by-tag-name-internal-ns document uri lname)) + +(defmethod dom:get-element-by-id ((document document) id) + (block t + (unless (dtd document) + (return-from t nil)) + (setf id (%rod id)) + (labels ((walk (n) + (dovector (c (dom:child-nodes n)) + (when (dom:element-p c) + (let ((e (cxml::find-element + (real-rod (dom:tag-name c)) + (dtd document)))) + (when e + (dolist (a (cxml::elmdef-attributes e)) + (when (eq :ID (cxml::attdef-type a)) + (let* ((name (%rod (cxml::attdef-name a))) + (value (dom:get-attribute c name))) + (when (and value (rod= value id)) + (return-from t c))))))) + (walk c))))) + (walk document)))) + + +;;; Node + +(defmethod dom:has-attributes ((element node)) + nil) + +(defmethod dom:is-supported ((node node) feature version) + (dom:has-feature 'implementation feature version)) + +(defmethod dom:parent-node ((node node)) + (slot-value node 'parent)) + +(defmethod dom:child-nodes ((node node)) + (slot-value node 'children)) + +(defmethod dom:first-child ((node node)) + (dom:item (slot-value node 'children) 0)) + +(defmethod dom:last-child ((node node)) + (with-slots (children) node + (if (plusp (length children)) + (elt children (1- (length children))) + nil))) + +(defmethod dom:previous-sibling ((node node)) + (with-slots (parent) node + (when parent + (with-slots (children) parent + (let ((index (1- (position node children)))) + (if (eql index -1) + nil + (elt children index))))))) + +(defmethod dom:next-sibling ((node node)) + (with-slots (parent) node + (when parent + (with-slots (children) parent + (let ((index (1+ (position node children)))) + (if (eql index (length children)) + nil + (elt children index))))))) + +(defmethod dom:owner-document ((node node)) + (slot-value node 'owner)) + +(defun ensure-valid-insertion-request (node new-child) + (assert-writeable node) + (unless (can-adopt-p node new-child) + (dom-error :HIERARCHY_REQUEST_ERR "~S cannot adopt ~S." node new-child)) + #+(or) ;XXX needs to be moved elsewhere + (when (eq (dom:node-type node) :document) + (let ((child-type (dom:node-type new-child))) + (when (and (member child-type '(:element :document-type)) + (find child-type (dom:child-nodes node) :key #'dom:node-type)) + (dom-error :HIERARCHY_REQUEST_ERR + "~S cannot adopt a second child of type ~S." + node child-type)))) + (unless (eq (if (eq (dom:node-type node) :document) + node + (dom:owner-document node)) + (dom:owner-document new-child)) + (dom-error :WRONG_DOCUMENT_ERR + "~S cannot adopt ~S, since it was created by a different document." + node new-child)) + (do ((n node (dom:parent-node n))) + ((null n)) + (when (eq n new-child) + (dom-error :HIERARCHY_REQUEST_ERR + "~S cannot adopt ~S, since that would create a cycle" + node new-child))) + (unless (null (slot-value new-child 'parent)) + (dom:remove-child (slot-value new-child 'parent) new-child))) + +(defmethod dom:insert-before ((node node) (new-child node) ref-child) + (ensure-valid-insertion-request node new-child) + (with-slots (children) node + (if ref-child + (let ((i (position ref-child children))) + (unless i + (dom-error :NOT_FOUND_ERR "~S is no child of ~S." ref-child node)) + (make-space children 1) + (move children children i (1+ i) (- (length children) i)) + (incf (fill-pointer children)) + (setf (elt children i) new-child)) + (vector-push-extend new-child children (extension children))) + (setf (slot-value new-child 'parent) node) + new-child)) + +(defmethod dom:insert-before + ((node node) (fragment document-fragment) ref-child) + (let ((children (dom:child-nodes fragment))) + (cxml::while (plusp (length children)) + (dom:insert-before node (elt children 0) ref-child))) + fragment) + +(defmethod dom:replace-child ((node node) (new-child node) (old-child node)) + (ensure-valid-insertion-request node new-child) + (with-slots (children) node + (let ((i (position old-child children))) + (unless i + (dom-error :NOT_FOUND_ERR "~S is no child of ~S." old-child node)) + (setf (elt children i) new-child)) + (setf (slot-value new-child 'parent) node) + (setf (slot-value old-child 'parent) nil) + old-child)) + +(defmethod dom:replace-child + ((node node) (new-child document-fragment) (old-child node)) + (dom:insert-before node new-child old-child) + (dom:remove-child node old-child)) + +(defmethod dom:remove-child ((node node) (old-child node)) + (assert-writeable node) + (with-slots (children) node + (let ((i (position old-child children))) + (unless i + (dom-error :NOT_FOUND_ERR "~A not found in ~A" old-child node)) + (move children children (1+ i) i (- (length children) i 1)) + (decf (fill-pointer children))) + (setf (slot-value old-child 'parent) nil) + old-child)) + +(defmethod dom:append-child ((node node) (new-child node)) + (ensure-valid-insertion-request node new-child) + (with-slots (children) node + (vector-push-extend new-child children (extension children)) + (setf (slot-value new-child 'parent) node) + new-child)) + +(defmethod dom:has-child-nodes ((node node)) + (plusp (length (slot-value node 'children)))) + +(defmethod dom:append-child ((node node) (new-child document-fragment)) + (assert-writeable node) + (let ((children (dom:child-nodes new-child))) + (cxml::while (plusp (length children)) + (dom:append-child node (elt children 0)))) + new-child) + +;; was auf node noch implemetiert werden muss: +;; - node-type +;; - can-adopt-p +;; - ggf attributes +;; - node-name +;; - node-value + +;; node-name + +(defmethod dom:node-name ((self document)) + #"#document") + +(defmethod dom:node-name ((self document-fragment)) + #"#document-fragment") + +(defmethod dom:node-name ((self text)) + #"#text") + +(defmethod dom:node-name ((self cdata-section)) + #"#cdata-section") + +(defmethod dom:node-name ((self comment)) + #"#comment") + +(defmethod dom:node-name ((self attribute)) + (dom:name self)) + +(defmethod dom:node-name ((self element)) + (dom:tag-name self)) + +(defmethod dom:node-name ((self document-type)) + (dom:name self)) + +(defmethod dom:node-name ((self notation)) + (dom:name self)) + +(defmethod dom:node-name ((self entity)) + (dom:name self)) + +(defmethod dom:node-name ((self entity-reference)) + (dom:name self)) + +(defmethod dom:node-name ((self processing-instruction)) + (dom:target self)) + +;; node-type + +(defmethod dom:node-type ((self document)) :document) +(defmethod dom:node-type ((self document-fragment)) :document-fragment) +(defmethod dom:node-type ((self text)) :text) +(defmethod dom:node-type ((self comment)) :comment) +(defmethod dom:node-type ((self cdata-section)) :cdata-section) +(defmethod dom:node-type ((self attribute)) :attribute) +(defmethod dom:node-type ((self element)) :element) +(defmethod dom:node-type ((self document-type)) :document-type) +(defmethod dom:node-type ((self notation)) :notation) +(defmethod dom:node-type ((self entity)) :entity) +(defmethod dom:node-type ((self entity-reference)) :entity-reference) +(defmethod dom:node-type ((self processing-instruction)) :processing-instruction) + +;; node-value + +(defmethod dom:node-value ((self document)) nil) +(defmethod dom:node-value ((self document-fragment)) nil) +(defmethod dom:node-value ((self character-data)) (dom:data self)) +(defmethod dom:node-value ((self attribute)) (dom:value self)) +(defmethod dom:node-value ((self element)) nil) +(defmethod dom:node-value ((self document-type)) nil) +(defmethod dom:node-value ((self notation)) nil) +(defmethod dom:node-value ((self entity)) nil) +(defmethod dom:node-value ((self entity-reference)) nil) +(defmethod dom:node-value ((self processing-instruction)) (dom:data self)) + +;; (setf node-value), first the meaningful cases... + +(defmethod (setf dom:node-value) (newval (self character-data)) + (assert-writeable self) + (setf (dom:data self) newval)) + +(defmethod (setf dom:node-value) (newval (self attribute)) + (assert-writeable self) + (setf (dom:value self) newval)) + +(defmethod (setf dom:node-value) (newval (self processing-instruction)) + (assert-writeable self) + (setf (dom:data self) newval)) + +;; ... and (setf node-value), part II. The DOM Level 1 spec fails to explain +;; this case, but it is covered by the (Level 1) test suite and clarified +;; in Level 2: +;; nodeValue of type DOMString +;; The value of this node, depending on its type; see the +;; table above. When it is defined to be null, setting +;; it has no effect. + +(defmethod (setf dom:node-value) (newval (self element)) + (declare (ignore newval))) + +(defmethod (setf dom:node-value) (newval (self entity-reference)) + (declare (ignore newval))) + +(defmethod (setf dom:node-value) (newval (self entity)) + (declare (ignore newval))) + +(defmethod (setf dom:node-value) (newval (self document)) + (declare (ignore newval))) + +(defmethod (setf dom:node-value) (newval (self document-type)) + (declare (ignore newval))) + +(defmethod (setf dom:node-value) (newval (self document-fragment)) + (declare (ignore newval))) + +(defmethod (setf dom:node-value) (newval (self notation)) + (declare (ignore newval))) + +;; attributes + +;; (gibt es nur auf element) + +(defmethod dom:attributes ((self node)) + nil) + +;; dann fehlt noch can-adopt und attribute conventions fuer adoption + +;;; NodeList + +(defun make-node-list (&optional initial-contents) + (make-array (length initial-contents) + :adjustable t + :fill-pointer (length initial-contents) + :initial-contents initial-contents)) + +(defmethod dom:item ((self vector) index) + (if (< index (length self)) + (elt self index) + nil)) + +(defmethod dom:length ((self vector)) + (length self)) + +;;; NAMED-NODE-MAP + +(defmethod dom:get-named-item ((self named-node-map) name) + (setf name (%rod name)) + (with-slots (items) self + (dolist (k items nil) + (when (rod= name (dom:node-name k)) + (return k))))) + +(defmethod dom:get-named-item-ns ((self named-node-map) uri lname) + (setf uri (%rod uri)) + (setf lname (%rod lname)) + (with-slots (items) self + (dolist (k items nil) + (when (and (rod= uri (dom:namespace-uri k)) + (rod= lname (dom:local-name k))) + (return k))))) + +(defun %set-named-item (map arg test) + (assert-writeable map) + (unless (eq (dom:node-type arg) (slot-value map 'element-type)) + (dom-error :HIERARCHY_REQUEST_ERR + "~S cannot adopt ~S, since it is not of type ~S." + map arg (slot-value map 'element-type))) + (unless (eq (dom:owner-document map) (dom:owner-document arg)) + (dom-error :WRONG_DOCUMENT_ERR + "~S cannot adopt ~S, since it was created by a different document." + map arg)) + (let ((old-map (slot-value arg 'map))) + (when (and old-map (not (eq old-map map))) + (dom-error :INUSE_ATTRIBUTE_ERR "Attribute node already mapped" arg))) + (setf (slot-value arg 'map) map) + (with-slots (items) map + (dolist (k items (progn (setf items (cons arg items)) nil)) + (when (funcall test k) + (setf items (cons arg (delete k items))) + (return k))))) + +(defmethod dom:set-named-item ((self named-node-map) arg) + (let ((name (dom:node-name arg))) + (%set-named-item self arg (lambda (k) (rod= name (dom:node-name k)))))) + +(defmethod dom:set-named-item-ns ((self named-node-map) arg) + (let ((uri (dom:namespace-uri arg)) + (lname (dom:local-name arg))) + (%set-named-item self + arg + (lambda (k) + (and (rod= lname (dom:local-name k)) + (rod= uri (dom:namespace-uri k))))))) + +(defmethod dom:remove-named-item ((self named-node-map) name) + (assert-writeable self) + (setf name (%rod name)) + (with-slots (items) self + (dolist (k items (dom-error :NOT_FOUND_ERR "~A not found in ~A" name self)) + (cond ((rod= name (dom:node-name k)) + (setf items (delete k items)) + (return k)))))) + +(defmethod dom:remove-named-item-ns ((self named-node-map) uri lname) + (assert-writeable self) + (setf uri (%rod uri)) + (setf lname (%rod lname)) + (with-slots (items) self + (dolist (k items + (dom-error :NOT_FOUND_ERR "~A not found in ~A" lname self)) + (when (and (rod= lname (dom:local-name k)) + (rod= uri (dom:namespace-uri k))) + (setf items (delete k items)) + (return k))))) + +(defmethod dom:length ((self named-node-map)) + (with-slots (items) self + (length items))) + +(defmethod dom:item ((self named-node-map) index) + (with-slots (items) self + (do ((nthcdr items (cdr nthcdr)) + (i index (1- i))) + ((zerop i) (car nthcdr))))) + +;;; CHARACTER-DATA + +(defmethod (setf dom:data) (newval (self character-data)) + (assert-writeable self) + (setf newval (%rod newval)) + (setf (slot-value self 'value) newval)) + +(defmethod dom:length ((node character-data)) + (length (slot-value node 'value))) + +(defmethod dom:substring-data ((node character-data) offset count) + (with-slots (value) node + (unless (<= 0 offset (length value)) + (dom-error :INDEX_SIZE_ERR "offset is invalid")) + (let ((end (min (length value) (+ offset count)))) + (subseq value offset end)))) + +(defmethod dom:append-data ((node character-data) arg) + (assert-writeable node) + (setq arg (%rod arg)) + (with-slots (value) node + (setf value (concatenate 'rod value arg))) + (values)) + +(defmethod dom:delete-data ((node character-data) offset count) + (assert-writeable node) + (with-slots (value) node + (unless (<= 0 offset (length value)) + (dom-error :INDEX_SIZE_ERR "offset is invalid")) + (when (minusp count) + (dom-error :INDEX_SIZE_ERR "count is negative")) + (setf count (min count (- (length value) offset))) + (let ((new (make-array (- (length value) count) + :element-type (array-element-type value)))) + (replace new value + :start1 0 :end1 offset + :start2 0 :end2 offset) + (replace new value + :start1 offset :end1 (length new) + :start2 (+ offset count) :end2 (length value)) + (setf value new))) + (values)) + +(defmethod dom:replace-data ((node character-data) offset count arg) + ;; Although we could implement this by calling DELETE-DATA, then INSERT-DATA, + ;; we implement this function directly to avoid creating temporary garbage. + (assert-writeable node) + (setf arg (%rod arg)) + (with-slots (value) node + (unless (<= 0 offset (length value)) + (dom-error :INDEX_SIZE_ERR "offset is invalid")) + (when (minusp count) + (dom-error :INDEX_SIZE_ERR "count is negative")) + (setf count (min count (- (length value) offset))) + (if (= count (length arg)) + (replace value arg + :start1 offset :end1 (+ offset count) + :start2 0 :end2 count) + (let ((new (make-array (+ (length value) (length arg) (- count)) + :element-type (array-element-type value)))) + (replace new value :end1 offset) + (replace new arg :start1 offset) + (replace new value + :start1 (+ offset (length arg)) + :start2 (+ offset count)) + (setf value new)))) + (values)) + +(defmethod dom:insert-data ((node character-data) offset arg) + (assert-writeable node) + (setf arg (%rod arg)) + (with-slots (value) node + (unless (<= 0 offset (length value)) + (dom-error :INDEX_SIZE_ERR "offset is invalid")) + (let ((new (make-array (+ (length value) (length arg)) + :element-type (array-element-type value))) + (arglen (length arg))) + (replace new value :end1 offset) + (replace new arg :start1 offset) + (replace new value :start1 (+ offset arglen) :start2 offset) + (setf value new))) + (values)) + +;;; ATTR +;;; +;;; An attribute value can be read and set as a string using DOM:VALUE +;;; or frobbed by changing the attribute's children! +;;; +;;; We store the value in a TEXT node and read this node's DATA slot +;;; when asked for our VALUE -- until the user changes the child nodes, +;;; in which case we have to compute VALUE by traversing the children. + +(defmethod dom:value ((node attribute)) + (with-slots (children) node + (cond + ((zerop (length children)) + #.(rod-string "")) + ((and (eql (length children) 1) + (eq (dom:node-type (elt children 0)) :text)) + ;; we have as single TEXT-NODE child, just return its DATA + (dom:data (elt children 0))) + (t + ;; traverse children to compute value + (attribute-to-string node))))) + +(defmethod (setf dom:value) (new-value (node attribute)) + (assert-writeable node) + (let ((rod (%rod new-value))) + (with-slots (children owner) node + ;; remove children, add new TEXT-NODE child + ;; (alas, we must not reuse an old TEXT-NODE) + (cxml::while (plusp (length children)) + (dom:remove-child node (dom:last-child node))) + (dom:append-child node (dom:create-text-node owner rod)))) + new-value) + +(defun attribute-to-string (attribute) + (let ((stream (make-rod-stream))) + (flet ((doit () + (dovector (child (dom:child-nodes attribute)) + (write-attribute-child child stream)))) + (doit) + (initialize-rod-stream stream) + (doit)) + (rod-stream-buf stream))) + +(defmethod write-attribute-child ((node node) stream) + (put-rod (dom:node-value node) stream)) + +(defmethod write-attribute-child ((node entity-reference) stream) + (dovector (child (dom:child-nodes node)) + (write-attribute-child child stream))) + +;;; ROD-STREAM als Ersatz fuer MAKE-STRING-OUTPUT-STREAM zu verwenden, +;;; nur dass der Buffer statische Groesse hat. Solange er NIL ist, +;;; zaehlt der Stream nur die Runen. Dann ruft man INITIALIZE-ROD-STREAM +;;; auf, um den Buffer zu erzeugen und die Position zurueckzusetzen, und +;;; schreibt alles abermals. Dann ist der Buffer gefuellt. +(defstruct rod-stream + (buf nil) + (position 0)) + +(defun put-rod (rod rod-stream) + (let ((buf (rod-stream-buf rod-stream))) + (when buf + (move rod buf 0 (rod-stream-position rod-stream) (length rod))) + (incf (rod-stream-position rod-stream) (length rod))) + rod) + +(defun initialize-rod-stream (stream) + (setf (rod-stream-buf stream) (make-rod (rod-stream-position stream))) + (setf (rod-stream-position stream) 0) + stream) + +;;; ELEMENT + +(defmethod dom:has-attributes ((element element)) + (plusp (length (dom:items (dom:attributes element))))) + +(defmethod dom:has-attribute ((element element) name) + (and (dom:get-named-item (dom:attributes element) name) t)) + +(defmethod dom:has-attribute-ns ((element element) uri lname) + (and (dom:get-named-item-ns (dom:attributes element) uri lname) t)) + +(defmethod dom:get-attribute-node ((element element) name) + (dom:get-named-item (dom:attributes element) name)) + +(defmethod dom:set-attribute-node ((element element) (new-attr attribute)) + (assert-writeable element) + (dom:set-named-item (dom:attributes element) new-attr)) + +(defmethod dom:get-attribute-node-ns ((element element) uri lname) + (dom:get-named-item-ns (dom:attributes element) uri lname)) + +(defmethod dom:set-attribute-node-ns ((element element) (new-attr attribute)) + (assert-writeable element) + (dom:set-named-item-ns (dom:attributes element) new-attr)) + +(defmethod dom:get-attribute ((element element) name) + (let ((a (dom:get-attribute-node element name))) + (if a + (dom:value a) + #""))) + +(defmethod dom:get-attribute-ns ((element element) uri lname) + (let ((a (dom:get-attribute-node-ns element uri lname))) + (if a + (dom:value a) + #""))) + +(defmethod dom:set-attribute ((element element) name value) + (assert-writeable element) + (with-slots (owner) element + (let ((attr (dom:create-attribute owner name))) + (setf (slot-value attr 'owner-element) element) + (setf (dom:value attr) value) + (dom:set-attribute-node element attr)) + (values))) + +(defmethod dom:set-attribute-ns ((element element) uri lname value) + (assert-writeable element) + (with-slots (owner) element + (let ((attr (dom:create-attribute-ns owner uri lname))) + (setf (slot-value attr 'owner-element) element) + (setf (dom:value attr) value) + (dom:set-attribute-node-ns element attr)) + (values))) + +(defmethod dom:remove-attribute ((element element) name) + (assert-writeable element) + (dom:remove-attribute-node element (dom:get-attribute-node element name))) + +(defmethod dom:remove-attribute-ns ((elt element) uri lname) + (assert-writeable elt) + (dom:remove-attribute-node elt (dom:get-attribute-node-ns elt uri lname))) + +(defmethod dom:remove-attribute-node ((element element) (old-attr attribute)) + (assert-writeable element) + (with-slots (items) (dom:attributes element) + (unless (find old-attr items) + (dom-error :NOT_FOUND_ERR "Attribute not found.")) + (setf items (remove old-attr items)) + (maybe-add-default-attribute element old-attr) + old-attr)) + +;; eek, defaulting: + +(defun maybe-add-default-attribute (element old-attr) + (let* ((qname (dom:name old-attr)) + (dtd (dtd (slot-value element 'owner))) + (e (when dtd (cxml::find-element + (real-rod (dom:tag-name element)) + dtd))) + (a (when e (cxml::find-attribute e (real-rod qname))))) + (when (and a (listp (cxml::attdef-default a))) + (let ((new (add-default-attribute element a))) + (setf (slot-value new 'namespace-uri) (dom:namespace-uri old-attr)) + (setf (slot-value new 'prefix) (dom:prefix old-attr)) + (setf (slot-value new 'local-name) (dom:local-name old-attr)))))) + +(defun add-default-attributes (element) + (let* ((dtd (dtd (slot-value element 'owner))) + (e (when dtd (cxml::find-element + (real-rod (dom:tag-name element)) + dtd)))) + (when e + (dolist (a (cxml::elmdef-attributes e)) + (when (and a + (listp (cxml::attdef-default a)) + (not (dom:get-attribute-node + element + (%rod (cxml::attdef-name a))))) + (let ((anode (add-default-attribute element a))) + (multiple-value-bind (prefix local-name) + (handler-case + (cxml::split-qname (cxml::attdef-name a)) + (cxml:well-formedness-violation (c) + (dom-error :NAMESPACE_ERR "~A" c))) + (when prefix (setf prefix (%rod prefix))) + (setf local-name (%rod local-name)) + ;; das ist fuer importnode07. + ;; so richtig ueberzeugend finde ich das ja nicht. + (setf (slot-value anode 'prefix) prefix) + (setf (slot-value anode 'local-name) local-name)))))))) + +(defun add-default-attribute (element adef) + (let* ((value (second (cxml::attdef-default adef))) + (owner (slot-value element 'owner)) + (anode (dom:create-attribute owner (cxml::attdef-name adef))) + (text (dom:create-text-node owner value))) + (setf (slot-value anode 'specified-p) nil) + (setf (slot-value anode 'owner-element) element) + (dom:append-child anode text) + (push anode (slot-value (dom:attributes element) 'items)) + anode)) + +(defmethod dom:remove-named-item ((self attribute-node-map) name) + name + (let ((k (call-next-method))) + (maybe-add-default-attribute (slot-value self 'element) k) + k)) + +(defmethod dom:remove-named-item-ns ((self attribute-node-map) uri lname) + uri lname + (let ((k (call-next-method))) + (maybe-add-default-attribute (slot-value self 'element) k) + k)) + +(defmethod dom:get-elements-by-tag-name ((element element) name) + (assert-writeable element) + (get-elements-by-tag-name-internal element name)) + +(defmethod dom:get-elements-by-tag-name-ns ((element element) uri lname) + (assert-writeable element) + (get-elements-by-tag-name-internal-ns element uri lname)) + +(defmethod dom:set-named-item :after ((self attribute-node-map) arg) + (setf (slot-value arg 'owner-element) + (slot-value self 'element))) + +(defmethod dom:set-named-item-ns :after ((self attribute-node-map) arg) + (setf (slot-value arg 'owner-element) + (slot-value self 'element))) + +(defmethod dom:normalize ((node node)) + (assert-writeable node) + (labels ((walk (n) + (when (eq (dom:node-type n) :element) + (map nil #'walk (dom:items (dom:attributes n)))) + (let ((children (dom:child-nodes n)) + (i 0) + (previous nil)) + ;; careful here, we're modifying the array we are iterating over + (cxml::while (< i (length children)) + (let ((child (elt children i))) + (cond + ((not (eq (dom:node-type child) :text)) + (setf previous nil) + (incf i)) + ((and previous (eq (dom:node-type previous) :text)) + (setf (slot-value previous 'value) + (concatenate 'rod + (dom:data previous) + (dom:data child))) + (dom:remove-child n child) + ;; not (incf i) + ) + ((zerop (length (dom:data child))) + (dom:remove-child n child) + ;; not (incf i) + ) + (t + (setf previous child) + (incf i)))))) + (map nil #'walk (dom:child-nodes n)))) + (walk node)) + (values)) + +;;; TEXT + +(defmethod dom:split-text ((text text) offset) + (assert-writeable text) + (with-slots (owner parent value) text + (unless (<= 0 offset (length value)) + (dom-error :INDEX_SIZE_ERR "offset is invalid")) + (prog1 + (dom:insert-before parent + (dom:create-text-node owner (subseq value offset)) + (dom:next-sibling text)) + (setf value (subseq value 0 offset))))) + +;;; COMMENT -- nix +;;; CDATA-SECTION -- nix + +;;; DOCUMENT-TYPE + +(defmethod dom:internal-subset ((node document-type)) + ;; FIXME: encoding ist falsch, anderen sink nehmen! + (if (and (slot-boundp node 'dom::%internal-subset) + ;; die damen und herren von der test suite sind wohl der meinung, + ;; dass ein leeres internal subset nicht vorhanden ist und + ;; wir daher nil liefern sollen. bittesehr! + (dom::%internal-subset node)) + (let ((sink + #+rune-is-character (cxml:make-string-sink) + #-rune-is-character (cxml:make-string-sink/utf8))) + (dolist (def (dom::%internal-subset node)) + (apply (car def) sink (cdr def))) + (sax:end-document sink)) + nil)) + +;;; NOTATION -- nix +;;; ENTITY -- nix + +;;; ENTITY-REFERENCE + +(defmethod initialize-instance :after ((instance entity-reference) &key) + (let* ((owner (dom:owner-document instance)) + (handler (make-dom-builder)) + (resolver (slot-value owner 'entity-resolver))) + (when resolver + (setf (document handler) owner) + (push instance (element-stack handler)) + #+cxml-system::utf8dom-file + (setf handler (cxml:make-recoder handler #'cxml:rod-to-utf8-string)) + (funcall resolver (real-rod (dom:name instance)) handler))) + (labels ((walk (n) + (setf (slot-value n 'read-only-p) t) + (when (dom:element-p n) + (setf (slot-value (dom:attributes n) 'read-only-p) t) + (map nil #'walk (dom:items (dom:attributes n)))) + (map nil #'walk (dom:child-nodes n)))) + (walk instance))) + +;;; PROCESSING-INSTRUCTION + +(defmethod (setf dom:data) (newval (self processing-instruction)) + (assert-writeable self) + (setf newval (%rod newval)) + (setf (slot-value self 'data) newval)) + +;; das koennte man auch mit einer GF machen +(defun can-adopt-p (parent child) + (member (dom:node-type child) + (let ((default '(:element :processing-instruction :comment :text + :cdata-section :entity-reference))) + (etypecase parent + (document + '(:element :processing-instruction :comment :document-type)) + (document-fragment default) + (document-type nil) + (entity-reference default) + (element default) + (attribute '(:text :entity-reference)) + (processing-instruction nil) + (comment nil) + (text nil) + (cdata-section nil) + (entity default) + (notation nil))))) + + +;;; predicates + +(defmethod dom:node-p ((object node)) t) +(defmethod dom:node-p ((object t)) nil) + +(defmethod dom:document-p ((object document)) t) +(defmethod dom:document-p ((object t)) nil) + +(defmethod dom:document-fragment-p ((object document-fragment)) t) +(defmethod dom:document-fragment-p ((object t)) nil) + +(defmethod dom:character-data-p ((object character-data)) t) +(defmethod dom:character-data-p ((object t)) nil) + +(defmethod dom:attribute-p ((object attribute)) t) +(defmethod dom:attribute-p ((object t)) nil) + +(defmethod dom:element-p ((object element)) t) +(defmethod dom:element-p ((object t)) nil) + +(defmethod dom:text-node-p ((object text)) t) +(defmethod dom:text-node-p ((object t)) nil) + +(defmethod dom:comment-p ((object comment)) t) +(defmethod dom:comment-p ((object t)) nil) + +(defmethod dom:cdata-section-p ((object cdata-section)) t) +(defmethod dom:cdata-section-p ((object t)) nil) + +(defmethod dom:document-type-p ((object document-type)) t) +(defmethod dom:document-type-p ((object t)) nil) + +(defmethod dom:notation-p ((object notation)) t) +(defmethod dom:notation-p ((object t)) nil) + +(defmethod dom:entity-p ((object entity)) t) +(defmethod dom:entity-p ((object t)) nil) + +(defmethod dom:entity-reference-p ((object entity-reference)) t) +(defmethod dom:entity-reference-p ((object t)) nil) + +(defmethod dom:processing-instruction-p ((object processing-instruction)) t) +(defmethod dom:processing-instruction-p ((object t)) nil) + +(defmethod dom:named-node-map-p ((object named-node-map)) t) +(defmethod dom:named-node-map-p ((object t)) nil) + + +;;; IMPORT-NODE + +(defvar *clone-not-import* nil) ;not beautiful, I know. See below. + +(defmethod import-node-internal (class document node deep &rest initargs) + (let ((result (apply #'make-instance class :owner document initargs))) + (when deep + (dovector (child (dom:child-nodes node)) + (dom:append-child result (dom:import-node document child t)))) + result)) + +(defmethod dom:import-node ((document document) (node t) deep) + (declare (ignore deep)) + (dom-error :NOT_SUPPORTED_ERR "not implemented")) + +(defmethod dom:import-node ((document document) (node attribute) deep) + (declare (ignore deep)) + (import-node-internal 'attribute + document node + t + :specified-p (dom:specified node) + :name (dom:name node) + :namespace-uri (dom:namespace-uri node) + :local-name (dom:local-name node) + :prefix (dom:prefix node) + :owner-element nil)) + +(defmethod dom:import-node ((document document) (node document-fragment) deep) + (import-node-internal 'document-fragment document node deep)) + +(defmethod dom:import-node ((document document) (node element) deep) + (let* ((attributes (make-instance 'attribute-node-map + :element-type :attribute + :owner document)) + (result (import-node-internal 'element document node deep + :attributes attributes + :namespace-uri (dom:namespace-uri node) + :local-name (dom:local-name node) + :prefix (dom:prefix node) + :tag-name (dom:tag-name node)))) + (setf (slot-value attributes 'element) result) + (dolist (attribute (dom:items (dom:attributes node))) + (when (or (dom:specified attribute) *clone-not-import*) + (let ((attr (dom:import-node document attribute t))) + (if (dom:namespace-uri attribute) + (dom:set-attribute-node-ns result attr) + (dom:set-attribute-node result attr))))) + (add-default-attributes result) + result)) + +(defmethod dom:import-node ((document document) (node entity) deep) + (import-node-internal 'entity document node deep + :name (dom:name node) + :public-id (dom:public-id node) + :system-id (dom:system-id node) + :notation-name (dom:notation-name node))) + +(defmethod dom:import-node ((document document) (node entity-reference) deep) + (declare (ignore deep)) + (import-node-internal 'entity-reference document node nil + :name (dom:name node))) + +(defmethod dom:import-node ((document document) (node notation) deep) + (import-node-internal 'notation document node deep + :name (dom:name node) + :public-id (dom:public-id node) + :system-id (dom:system-id node))) + +(defmethod dom:import-node + ((document document) (node processing-instruction) deep) + (import-node-internal 'processing-instruction document node deep + :target (dom:target node) + :data (dom:data node))) + +;; TEXT_NODE, CDATA_SECTION_NODE, COMMENT_NODE +(defmethod dom:import-node + ((document document) (node character-data) deep) + (import-node-internal (class-of node) document node deep + :data (copy-seq (dom:data node)))) + +;;; CLONE-NODE +;;; +;;; As far as I can tell, cloneNode is the same as importNode, except +;;; for one difference involving element attributes: importNode imports +;;; only specified attributes, cloneNode copies even default values. +;;; +;;; Since I don't want to reimplement all of importNode here, we run +;;; importNode with a special flag... + +(defmethod dom:clone-node ((node node) deep) + (let ((*clone-not-import* t)) + (dom:import-node (dom:owner-document node) node deep))) + +;; extension: +(defmethod dom:clone-node ((node document) deep) + (let* ((document (make-instance 'document)) + (original-doctype (dom:doctype node)) + (doctype + (when original-doctype + (make-instance 'document-type + :owner document + :name (dom:name original-doctype) + :public-id (dom:public-id original-doctype) + :system-id (dom:system-id original-doctype) + :notations (make-instance 'named-node-map + :element-type :notation + :owner document + :items (dom:items (dom:notations original-doctype))) + :entities (make-instance 'named-node-map + :element-type :entity + :owner document + :items (dom:items + (dom:entities original-doctype))))))) + (setf (slot-value document 'owner) nil) + (setf (slot-value document 'doc-type) doctype) + (setf (slot-value document 'dtd) (dtd node)) + (setf (slot-value document 'entity-resolver) + (slot-value node 'entity-resolver)) + (setf (slot-value (dom:entities doctype) 'read-only-p) t) + (setf (slot-value (dom:notations doctype) 'read-only-p) t) + (when (and doctype (slot-boundp doctype 'dom::%internal-subset)) + (setf (dom::%internal-subset doctype) + (dom::%internal-subset original-doctype))) + (when (and (dom:document-element node) deep) + (let* ((*clone-not-import* t) + (clone (dom:import-node document (dom:document-element node) t))) + (dom:append-child document clone))) + document)) + + +;;; Erweiterung + +(defun create-document (&optional document-element) + ;; Um ein neues Dokumentenobject zu erzeugen, parsen wir einfach ein + ;; Dummydokument. + (let* ((handler (make-dom-builder)) + (cxml::*ctx* (cxml::make-context :handler handler)) + (result + (progn + (sax:start-document handler) + (sax:end-document handler)))) + (when document-element + (dom:append-child result (dom:import-node result document-element t))) + result)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/dom-sax.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/dom-sax.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/dom-sax.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,95 @@ +;;;; dom-sax.lisp -- DOM walker +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: David Lichteblau <david(a)lichteblau.com> +;;;; Copyright (c) 2004 knowledgeTools Int. GmbH + +(in-package :cxml) + +(defun dom:map-document + (handler document + &key (include-xmlns-attributes sax:*include-xmlns-attributes*) + include-doctype + include-default-values + (recode (and #+rune-is-integer (typep document 'utf8-dom::node)))) + (declare (ignorable recode)) + #+rune-is-integer + (when recode + (setf handler (make-recoder handler #'utf8-string-to-rod))) + (sax:start-document handler) + (when include-doctype + (let ((doctype (dom:doctype document))) + (when doctype + (sax:start-dtd handler + (dom:name doctype) + (dom:public-id doctype) + (dom:system-id doctype)) + (ecase include-doctype + (:full-internal-subset + (when (slot-boundp doctype 'dom::%internal-subset) + (sax:start-internal-subset handler) + (dolist (def (dom::%internal-subset doctype)) + (apply (car def) handler (cdr def))) + (sax:end-internal-subset handler))) + (:canonical-notations + ;; need notations for canonical mode 2 + (let* ((ns (dom:notations doctype)) + (a (make-array (dom:length ns)))) + (when (plusp (dom:length ns)) + (sax:start-internal-subset handler) + ;; get them + (dotimes (k (dom:length ns)) + (setf (elt a k) (dom:item ns k))) + ;; sort them + (setf a (sort a #'rod< :key #'dom:name)) + (loop for n across a do + (sax:notation-declaration handler + (dom:name n) + (dom:public-id n) + (dom:system-id n))) + (sax:end-internal-subset handler))))) + (sax:end-dtd handler)))) + (labels ((walk (node) + (dom:do-node-list (child (dom:child-nodes node)) + (ecase (dom:node-type child) + (:element + (let ((attlist + (compute-attributes child + include-xmlns-attributes + include-default-values)) + (uri (dom:namespace-uri child)) + (lname (dom:local-name child)) + (qname (dom:tag-name child))) + (sax:start-element handler uri lname qname attlist) + (walk child) + (sax:end-element handler uri lname qname))) + (:cdata-section + (sax:start-cdata handler) + (sax:characters handler (dom:data child)) + (sax:end-cdata handler)) + (:text + (sax:characters handler (dom:data child))) + (:comment + (sax:comment handler (dom:data child))) + (:processing-instruction + (sax:processing-instruction handler + (dom:target child) + (dom:data child))))))) + (walk document)) + (sax:end-document handler)) + +(defun compute-attributes (element xmlnsp defaultp) + (let ((results '())) + (dom:do-node-list (a (dom:attributes element)) + (when (and (or defaultp (dom:specified a)) + (or xmlnsp (not (cxml::xmlns-attr-p (rod (dom:name a)))))) + (push + (sax:make-attribute :qname (dom:name a) + :value (dom:value a) + :local-name (dom:local-name a) + :namespace-uri (dom:namespace-uri a) + :specified-p (dom:specified a)) + results))) + (reverse results))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/package.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/dom/package.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,161 @@ +;;;; package.lisp -- Paketdefinition +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. + +(in-package :cl-user) + +(defpackage :dom + (:use) + (:export + ;; DOM 2 functions + #:owner-element + #:import-node + #:create-element-ns + #:create-attribute-ns + #:get-elements-by-tag-name-ns + #:get-element-by-id + #:get-named-item-ns + #:set-named-item-ns + #:remove-named-item-ns + #:is-supported + #:has-attributes + #:namespace-uri + #:prefix + #:local-name + #:internal-subset + #:create-document-type + #:create-document + #:get-attribute-ns + #:set-attribute-ns + #:remove-attribute-ns + #:get-attribute-node-ns + #:set-attribute-node-ns + #:has-attribute + #:has-attribute-ns + + ;; DOM 1 functions + #:has-feature + #:doctype + #:implementation + #:document-element + #:create-element + #:create-document-fragment + #:create-text-node + #:create-comment + #:create-cdata-section + #:create-processing-instruction + #:create-attribute + #:create-entity-reference + #:get-elements-by-tag-name + #:node-name + #:node-value + #:node-type + #:parent-node + #:child-nodes + #:first-child + #:last-child + #:previous-sibling + #:next-sibling + #:attributes + #:owner-document + #:insert-before + #:replace-child + #:remove-child + #:append-child + #:has-child-nodes + #:clone-node + #:item + #:length + #:get-named-item + #:set-named-item + #:remove-named-item + #:data + #:substring-data + #:append-data + #:insert-data + #:delete-data + #:replace-data + #:name + #:specified + #:value + #:tag-name + #:get-attribute + #:set-attribute + #:remove-attribute + #:get-attribute-node + #:set-attribute-node + #:remove-attribute-node + #:normalize + #:split-text + #:entities + #:notations + #:public-id + #:system-id + #:notation-name + #:target + #:code + + ;; IDL interfaces, exported "inofficially" + #:node + #:document + #:document-fragment + #:character-data + #:attr + #:element + #:text + #:comment + #:cdata-section + #:document-type + #:notation + #:entity + #:entity-reference + #:processing-instruction + #:named-node-map + ;; no classes: +;;; #:dom-implementation +;;; #:node-list + + ;; + #:items + + ;; + #:node-p + #:document-p + #:document-fragment-p + #:character-data-p + #:attribute-p + #:element-p + #:text-node-p + #:comment-p + #:cdata-section-p + #:document-type-p + #:notation-p + #:entity-p + #:entity-reference-p + #:processing-instruction-p + #:named-node-map-p + + #:map-node-list + #:do-node-list + #:map-node-map + #:do-node-map + #:create-document + #:map-document)) + +(defclass dom:node () ()) +(defclass dom:document (dom:node) ()) +(defclass dom:document-fragment (dom:node) ()) +(defclass dom:character-data (dom:node) ()) +(defclass dom:attr (dom:node) ()) +(defclass dom:element (dom:node) ()) +(defclass dom:text (dom:character-data) ()) +(defclass dom:comment (dom:character-data) ()) +(defclass dom:cdata-section (dom:text) ()) +(defclass dom:document-type (dom:node) ()) +(defclass dom:notation (dom:node) ()) +(defclass dom:entity (dom:node) ()) +(defclass dom:entity-reference (dom:node) ()) +(defclass dom:processing-instruction (dom:node) ()) + +(defclass dom:named-node-map () ()) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/Entries 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/Entries 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,5 @@ +/klacks-impl.lisp/1.11/Sat Jun 16 09:41:22 2007// +/klacks.lisp/1.8/Tue May 1 18:21:41 2007// +/package.lisp/1.6/Tue May 1 18:21:41 2007// +/tap-source.lisp/1.2/Tue May 1 18:21:41 2007// +D Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/Repository 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/Repository 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +cxml/klacks Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/Root 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/CVS/Root 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +:ext:dlichteblau@common-lisp.net:/project/cxml/cvsroot Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/klacks-impl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/klacks-impl.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/klacks-impl.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,529 @@ +;;; -*- Mode: Lisp; readtable: runes; -*- +;;; (c) copyright 2007 David Lichteblau + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 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 +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library 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. + +(in-package :cxml) + +(defclass cxml-source (klacks:source) + (;; args to make-source + (context :initarg :context) + (validate :initarg :validate) + (root :initarg :root) + (dtd :initarg :dtd) + (error-culprit :initarg :error-culprit) + ;; current state + (continuation) + (current-key :initform nil) + (current-values) + (current-attributes) + (cdata-section-p :reader klacks:current-cdata-section-p) + ;; extra WITH-SOURCE magic + (data-behaviour :initform :DTD) + (namespace-stack :initform (list *initial-namespace-bindings*)) + (current-namespace-declarations) + (temporary-streams :initform nil) + (scratch-pad :initarg :scratch-pad) + (scratch-pad-2 :initarg :scratch-pad-2) + (scratch-pad-3 :initarg :scratch-pad-3) + (scratch-pad-4 :initarg :scratch-pad-4))) + +(defmethod klacks:close-source ((source cxml-source)) + (dolist (xstream (slot-value source 'temporary-streams)) + ;; fixme: error handling? + (close-xstream xstream))) + +(defmacro with-source ((source &rest slots) &body body) + (let ((s (gensym))) + `(let* ((,s ,source) + (*ctx* (slot-value ,s 'context)) + (*validate* (slot-value ,s 'validate)) + (*data-behaviour* (slot-value source 'data-behaviour)) + (*namespace-bindings* (car (slot-value source 'namespace-stack))) + (*scratch-pad* (slot-value source 'scratch-pad)) + (*scratch-pad-2* (slot-value source 'scratch-pad-2)) + (*scratch-pad-3* (slot-value source 'scratch-pad-3)) + (*scratch-pad-4* (slot-value source 'scratch-pad-4))) + (handler-case + (with-slots (,@slots) ,s + ,@body) + (runes-encoding:encoding-error (c) + (wf-error (slot-value ,s 'error-culprit) "~A" c)))))) + +(defun fill-source (source) + (with-slots (current-key current-values continuation) source + (unless current-key + (setf current-key :bogus) + (setf continuation (funcall continuation)) + (assert (not (eq current-key :bogus)))))) + +(defmethod klacks:peek ((source cxml-source)) + (with-source (source current-key current-values) + (fill-source source) + (apply #'values current-key current-values))) + +(defmethod klacks:peek-value ((source cxml-source)) + (with-source (source current-key current-values) + (fill-source source) + (apply #'values current-values))) + +(defmethod klacks:peek-next ((source cxml-source)) + (with-source (source current-key current-values) + (setf current-key nil) + (fill-source source) + (apply #'values current-key current-values))) + +(defmethod klacks:consume ((source cxml-source)) + (with-source (source current-key current-values) + (fill-source source) + (multiple-value-prog1 + (apply #'values current-key current-values) + (setf current-key nil)))) + +(defmethod klacks:map-attributes (fn (source cxml-source)) + (dolist (a (slot-value source 'current-attributes)) + (funcall fn + (sax:attribute-namespace-uri a) + (sax:attribute-local-name a) + (sax:attribute-qname a) + (sax:attribute-value a) + (sax:attribute-specified-p a)))) + +(defmethod klacks:get-attribute + ((source cxml-source) lname &optional uri) + (dolist (a (slot-value source 'current-attributes)) + (when (and (equal (sax:attribute-local-name a) lname) + (equal (sax:attribute-namespace-uri a) uri)) + (return (sax:attribute-value a))))) + +(defmethod klacks:list-attributes ((source cxml-source)) + (slot-value source 'current-attributes)) + +(defun make-source + (input &rest args + &key validate dtd root entity-resolver disallow-internal-subset + (buffering t) pathname) + (declare (ignore validate dtd root entity-resolver disallow-internal-subset)) + (etypecase input + (xstream + (when (and (not buffering) (< 1 (runes::xstream-speed input))) + (warn "make-source called with !buffering, but xstream is buffering")) + (let ((*ctx* nil)) + (let ((zstream (make-zstream :input-stack (list input)))) + (peek-rune input) + (with-scratch-pads () + (apply #'%make-source + zstream + (loop + for (name value) on args by #'cddr + unless (member name '(:pathname :buffering)) + append (list name value))))))) + (stream + (let ((xstream (make-xstream input :speed (if buffering 8192 1)))) + (setf (xstream-name xstream) + (make-stream-name + :entity-name "main document" + :entity-kind :main + :uri (pathname-to-uri + (merge-pathnames (or pathname (pathname input)))))) + (apply #'make-source xstream args))) + (pathname + (let* ((xstream + (make-xstream (open input :element-type '(unsigned-byte 8)) + :speed (if buffering 8192 1)))) + (setf (xstream-name xstream) + (make-stream-name + :entity-name "main document" + :entity-kind :main + :uri (pathname-to-uri (merge-pathnames input)))) + (let ((source (apply #'make-source + xstream + :pathname input + args))) + (push xstream (slot-value source 'temporary-streams)) + source))) + (rod + (let ((xstream (string->xstream input))) + (setf (xstream-name xstream) + (make-stream-name + :entity-name "main document" + :entity-kind :main + :uri nil)) + (apply #'make-source xstream args))) + (array + (make-source (cxml::make-octet-input-stream input))))) + +(defun %make-source + (input &key validate dtd root entity-resolver disallow-internal-subset + error-culprit) + ;; check types of user-supplied arguments for better error messages: + (check-type validate boolean) + (check-type dtd (or null extid)) + (check-type root (or null rod)) + (check-type entity-resolver (or null function symbol)) + (check-type disallow-internal-subset boolean) + (let* ((xstream (car (zstream-input-stack input))) + (name (xstream-name xstream)) + (base (when name (stream-name-uri name))) + (context + (make-context :main-zstream input + :entity-resolver entity-resolver + :base-stack (list (or base "")) + :disallow-internal-subset disallow-internal-subset)) + (source + (make-instance 'cxml-source + :context context + :validate validate + :dtd dtd + :root root + :error-culprit error-culprit + :scratch-pad *scratch-pad* + :scratch-pad-2 *scratch-pad-2* + :scratch-pad-3 *scratch-pad-3* + :scratch-pad-4 *scratch-pad-4*))) + (setf (handler context) (make-instance 'klacks-dtd-handler :source source)) + (setf (slot-value source 'continuation) + (lambda () (klacks/xmldecl source input))) + source)) + +(defun klacks/xmldecl (source input) + (with-source (source current-key current-values) + (let ((hd (p/xmldecl input))) + (setf current-key :start-document) + (setf current-values + (when hd + (list (xml-header-version hd) + (xml-header-encoding hd) + (xml-header-standalone-p hd)))) + (lambda () + (klacks/misc*-2 source input + (lambda () + (klacks/doctype source input))))))) + +(defun klacks/misc*-2 (source input successor) + (with-source (source current-key current-values) + (multiple-value-bind (cat sem) (peek-token input) + (case cat + (:COMMENT + (setf current-key :comment) + (setf current-values (list sem)) + (consume-token input) + (lambda () (klacks/misc*-2 source input successor))) + (:PI + (setf current-key :processing-instruction) + (setf current-values (list (car sem) (cdr sem))) + (consume-token input) + (lambda () (klacks/misc*-2 source input successor))) + (:S + (consume-token input) + (klacks/misc*-2 source input successor)) + (t + (funcall successor)))))) + +(defun klacks/doctype (source input) + (with-source (source current-key current-values validate dtd) + (let ((cont (lambda () (klacks/finish-doctype source input))) + l) + (prog1 + (cond + ((eq (peek-token input) :<!DOCTYPE) + (setf l (cdr (p/doctype-decl input dtd))) + (lambda () (klacks/misc*-2 source input cont))) + (dtd + (setf l (cdr (synthesize-doctype dtd input))) + cont) + ((and validate (not dtd)) + (validity-error "invalid document: no doctype")) + (t + (return-from klacks/doctype + (funcall cont)))) + (destructuring-bind (&optional name extid) l + (setf current-key :dtd) + (setf current-values + (list name + (and extid (extid-public extid)) + (and extid (extid-system extid))))))))) + +(defun klacks/finish-doctype (source input) + (with-source (source current-key current-values root data-behaviour) + (ensure-dtd) + (when root + (setf (model-stack *ctx*) (list (make-root-model root)))) + (setf data-behaviour :DOC) + (setf *data-behaviour* :DOC) + (fix-seen-< input) + (let* ((final + (lambda () + (klacks/eof source input))) + (next + (lambda () + (setf data-behaviour :DTD) + (setf *data-behaviour* :DTD) + (klacks/misc*-2 source input final)))) + (klacks/element source input next)))) + +(defun klacks/eof (source input) + (with-source (source current-key current-values) + (p/eof input) + (klacks:close-source source) + (setf current-key :end-document) + (setf current-values nil) + (lambda () (klacks/nil source)))) + +(defun klacks/nil (source) + (with-source (source current-key current-values) + (setf current-key nil) + (setf current-values nil) + (labels ((klacks/done () + (setf current-key nil) + (setf current-values nil) + #'klacks/done)) + #'klacks/done))) + +(defun klacks/element (source input cont) + (with-source (source current-key current-values current-attributes + current-namespace-declarations) + (multiple-value-bind (cat n-b new-b uri lname qname attrs) (p/sztag input) + (setf current-key :start-element) + (setf current-values (list uri lname qname)) + (setf current-attributes attrs) + (setf current-namespace-declarations new-b) + (if (eq cat :stag) + (lambda () + (klacks/element-2 source input n-b cont)) + (lambda () + (klacks/ztag source cont)))))) + +(defun klacks/ztag (source cont) + (with-source (source current-key current-values current-attributes) + (setf current-key :end-element) + (setf current-attributes nil) + (validate-end-element *ctx* (third current-values)) + cont)) + +(defun klacks/element-2 (source input n-b cont) + (with-source (source + current-key current-values current-attributes namespace-stack + current-namespace-declarations) + (let ((values* current-values) + (new-b current-namespace-declarations)) + (setf current-attributes nil) + (push n-b namespace-stack) + (let ((finish + (lambda () + (setf current-namespace-declarations new-b) + (klacks/element-3 source input values* cont)))) + (klacks/content source input finish))))) + +(defun klacks/element-3 (source input tag-values cont) + (with-source (source current-key current-values current-attributes) + (setf current-key :end-element) + (setf current-values tag-values) + (let ((qname (third tag-values))) + (p/etag input qname) + (validate-end-element *ctx* qname)) + cont)) + +(defun klacks/content (source input cont) + (with-source (source current-key current-values cdata-section-p) + (let ((recurse (lambda () (klacks/content source input cont)))) + (multiple-value-bind (cat sem) (peek-token input) + (case cat + ((:stag :ztag) + (klacks/element source input recurse)) + ((:CDATA) + (process-characters input sem) + (setf current-key :characters) + (setf current-values (list sem)) + (setf cdata-section-p nil) + recurse) + ((:ENTITY-REF) + (let ((name sem)) + (consume-token input) + (klacks/entity-reference source input name recurse))) + ((:<!\[) + (setf current-key :characters) + (setf current-values (list (process-cdata-section input))) + (setf cdata-section-p t) + recurse) + ((:PI) + (setf current-key :processing-instruction) + (setf current-values (list (car sem) (cdr sem))) + (consume-token input) + recurse) + ((:COMMENT) + (setf current-key :comment) + (setf current-values (list sem)) + (consume-token input) + recurse) + (otherwise + (funcall cont))))))) + +(defun klacks/entity-reference (source zstream name cont) + (assert (not (zstream-token-category zstream))) + (with-source (source temporary-streams context) + (let ((new-xstream (entity->xstream zstream name :general nil))) + (push new-xstream temporary-streams) + (push :stop (zstream-input-stack zstream)) + (zstream-push new-xstream zstream) + (push (stream-name-uri (xstream-name new-xstream)) (base-stack context)) + (let ((next + (lambda () + (klacks/entity-reference-2 source zstream new-xstream cont)))) + (etypecase (checked-get-entdef name :general) + (internal-entdef + (klacks/content source zstream next)) + (external-entdef + (klacks/ext-parsed-ent source zstream next))))))) + +(defun klacks/entity-reference-2 (source zstream new-xstream cont) + (with-source (source temporary-streams context) + (unless (eq (peek-token zstream) :eof) + (wf-error zstream "Trailing garbage. - ~S" (peek-token zstream))) + (assert (eq (peek-token zstream) :eof)) + (assert (eq (pop (zstream-input-stack zstream)) new-xstream)) + (assert (eq (pop (zstream-input-stack zstream)) :stop)) + (pop (base-stack context)) + (setf (zstream-token-category zstream) nil) + (setf temporary-streams (remove new-xstream temporary-streams)) + (close-xstream new-xstream) + (funcall cont))) + +(defun klacks/ext-parsed-ent (source input cont) + (with-source (source) + (when (eq (peek-token input) :xml-decl) + (let ((hd (parse-text-decl (cdr (nth-value 1 (peek-token input)))))) + (setup-encoding input hd)) + (consume-token input)) + (set-full-speed input) + (klacks/content source input cont))) + + +;;;; terrible kludges + +(defclass klacks-dtd-handler () + ((handler-source :initarg :source :reader handler-source) + (internal-subset-p :initform nil :accessor handler-internal-subset-p))) + +(defmethod sax:start-internal-subset ((handler klacks-dtd-handler)) + (setf (slot-value (handler-source handler) 'internal-declarations) '()) + (setf (handler-internal-subset-p handler) t)) + +(defmethod sax:end-internal-subset ((handler klacks-dtd-handler)) + (setf (handler-internal-subset-p handler) nil)) + +(defmethod sax:entity-resolver ((handler klacks-dtd-handler) fn) + (setf (slot-value (handler-source handler) 'dom-impl-entity-resolver) fn)) + +(defmethod sax::dtd ((handler klacks-dtd-handler) dtd) + (setf (slot-value (handler-source handler) 'dom-impl-dtd) dtd)) + +(defmethod sax:end-dtd ((handler klacks-dtd-handler)) + (let ((source (handler-source handler))) + (when (slot-boundp source 'internal-declarations) + (setf (slot-value source 'internal-declarations) + (reverse (slot-value source 'internal-declarations))) + (setf (slot-value source 'external-declarations) + (reverse (slot-value source 'external-declarations)))))) + +(macrolet + ((defhandler (name &rest args) + `(defmethod ,name ((handler klacks-dtd-handler) ,@args) + (let ((source (handler-source handler)) + (spec (list ',name ,@args))) + (if (handler-internal-subset-p handler) + (push spec (slot-value source 'internal-declarations)) + (push spec (slot-value source 'external-declarations))))))) + (defhandler sax:unparsed-entity-declaration + name public-id system-id notation-name) + (defhandler sax:external-entity-declaration + kind name public-id system-id) + (defhandler sax:internal-entity-declaration + kind name value) + (defhandler sax:notation-declaration + name public-id system-id) + (defhandler sax:element-declaration + name model) + (defhandler sax:attribute-declaration + element-name attribute-name type default)) + + +;;;; locator + +(defun source-xstream (source) + (car (zstream-input-stack (main-zstream (slot-value source 'context))))) + +(defun source-stream-name (source) + (let ((xstream (source-xstream source))) + (if xstream + (xstream-name xstream) + nil))) + +(defmethod klacks:current-line-number ((source cxml-source)) + (let ((x (source-xstream source))) + (if x + (xstream-line-number x) + nil))) + +(defmethod klacks:current-column-number ((source cxml-source)) + (let ((x (source-xstream source))) + (if x + (xstream-column-number x) + nil))) + +(defmethod klacks:current-system-id ((source cxml-source)) + (let ((name (source-stream-name source))) + (if name + (stream-name-uri name) + nil))) + +(defmethod klacks:current-xml-base ((source cxml-source)) + (car (base-stack (slot-value source 'context)))) + +(defmethod klacks:map-current-namespace-declarations (fn (source cxml-source)) + (loop + for (prefix . uri) in (slot-value source 'current-namespace-declarations) + do + (funcall fn prefix uri))) + +(defmethod klacks:find-namespace-binding (prefix (source cxml-source)) + (with-source (source) + (find-namespace-binding prefix))) + +(defmethod klacks:decode-qname (qname (source cxml-source)) + (with-source (source) + (multiple-value-bind (prefix local-name) (split-qname qname) + (values (and prefix (find-namespace-binding prefix)) + local-name + prefix)))) + + +;;;; debugging + +#+(or) +(trace CXML::KLACKS/DOCTYPE + CXML::KLACKS/EXT-PARSED-ENT + CXML::KLACKS/MISC*-2 + CXML::KLACKS/ENTITY-REFERENCE + CXML::KLACKS/ENTITY-REFERENCE-2 + CXML::KLACKS/ELEMENT + CXML::KLACKS/ZTAG + CXML::KLACKS/XMLDECL + CXML::KLACKS/FINISH-DOCTYPE + CXML::KLACKS/ELEMENT-3 + CXML::KLACKS/EOF + CXML::KLACKS/ELEMENT-2 + CXML::KLACKS/CONTENT ) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/klacks.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/klacks.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/klacks.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,253 @@ +;;; -*- Mode: Lisp; readtable: runes; -*- +;;; (c) copyright 2007 David Lichteblau + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 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 +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library 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. + +(in-package :cxml) + +(defclass klacks:source () + ( + ;; fixme, terrible DTD kludges + (internal-declarations) + (external-declarations :initform nil) + (dom-impl-dtd :initform nil) + (dom-impl-entity-resolver :initform nil))) + +(defgeneric klacks:close-source (source)) + +(defgeneric klacks:peek (source)) +(defgeneric klacks:peek-value (source)) +(defgeneric klacks:consume (source)) + +(defgeneric klacks:map-attributes (fn source)) +(defgeneric klacks:list-attributes (source)) +(defgeneric klacks:get-attribute (source lname &optional uri)) +;;;(defgeneric klacks:current-uri (source)) +;;;(defgeneric klacks:current-lname (source)) +;;;(defgeneric klacks:current-qname (source)) +;;;(defgeneric klacks:current-characters (source)) +(defgeneric klacks:current-cdata-section-p (source)) +(defgeneric klacks:map-current-namespace-declarations (fn source)) + +(defgeneric klacks:current-line-number (source)) +(defgeneric klacks:current-column-number (source)) +(defgeneric klacks:current-system-id (source)) +(defgeneric klacks:current-xml-base (source)) + +(defgeneric klacks:find-namespace-binding (prefix source)) +(defgeneric klacks:decode-qname (qname source)) + +(defmacro klacks:with-open-source ((var source) &body body) + `(let ((,var ,source)) + (unwind-protect + (progn ,@body) + (klacks:close-source ,var)))) + +(defun klacks:current-uri (source) + (multiple-value-bind (key uri lname qname) (klacks:peek source) + (declare (ignore lname qname)) + (check-type key (member :start-element :end-element)) + uri)) + +(defun klacks:current-lname (source) + (multiple-value-bind (key uri lname qname) (klacks:peek source) + (declare (ignore uri qname)) + (check-type key (member :start-element :end-element)) + lname)) + +(defun klacks:current-qname (source) + (multiple-value-bind (key uri lname qname) (klacks:peek source) + (declare (ignore uri lname)) + (check-type key (member :start-element :end-element)) + qname)) + +(defun klacks:current-characters (source) + (multiple-value-bind (key characters) (klacks:peek source) + (check-type key (member :characters)) + characters)) + +(defun klacks:serialize-event (source handler &key (consume t)) + (multiple-value-bind (key a b c) (klacks:peek source) + (let ((result nil)) + (case key + (:start-document + (sax:start-document handler) + (loop for (prefix . uri) in *initial-namespace-bindings* do + (sax:start-prefix-mapping handler prefix uri))) + (:characters + (cond + ((klacks:current-cdata-section-p source) + (sax:start-cdata source) + (sax:characters handler a) + (sax:end-cdata source)) + (T + (sax:characters handler a)))) + (:processing-instruction + (sax:processing-instruction handler a b)) + (:comment + (sax:comment handler a)) + (:dtd + (sax:start-dtd handler a b c) + (when (slot-boundp source 'internal-declarations) + (sax:start-internal-subset handler) + (serialize-declaration-kludge + (slot-value source 'internal-declarations) + handler) + (sax:end-internal-subset handler)) + (serialize-declaration-kludge + (slot-value source 'external-declarations) + handler) + (sax:end-dtd handler) + (sax:entity-resolver handler + (slot-value source 'dom-impl-entity-resolver)) + (sax::dtd handler (slot-value source 'dom-impl-dtd))) + (:start-element + (klacks:map-current-namespace-declarations + (lambda (prefix uri) + (sax:start-prefix-mapping handler prefix uri)) + source) + (sax:start-element handler a b c (klacks:list-attributes source))) + (:end-element + (sax:end-element handler a b c) + (klacks:map-current-namespace-declarations + (lambda (prefix uri) + (declare (ignore uri)) + (sax:end-prefix-mapping handler prefix)) + source)) + (:end-document + (loop for (prefix . nil) in *initial-namespace-bindings* do + (sax:end-prefix-mapping handler prefix)) + (setf result (sax:end-document handler))) + ((nil) + (error "serialize-event read past end of document")) + (t + (error "unexpected klacks key: ~A" key))) + (when consume + (klacks:consume source)) + result))) + +(defun serialize-declaration-kludge (list handler) + (loop + for (fn . args) in list + do (apply fn handler args))) + +(defun klacks:serialize-source (source handler) + (loop + (let ((document (klacks:serialize-event source handler))) + (when document + (return document))))) + +(defclass klacksax (sax:sax-parser) + ((source :initarg :source))) + +(defmethod sax:line-number ((parser klacksax)) + (klacks:current-line-number (slot-value parser 'source))) + +(defmethod sax:column-number ((parser klacksax)) + (klacks:current-column-number (slot-value parser 'source))) + +(defmethod sax:system-id ((parser klacksax)) + (klacks:current-system-id (slot-value parser 'source))) + +(defmethod sax:xml-base ((parser klacksax)) + (klacks:current-xml-base (slot-value parser 'source))) + +(defun klacks:serialize-element (source handler &key (document-events t)) + (unless (eq (klacks:peek source) :start-element) + (error "not at start of element")) + (sax:register-sax-parser handler (make-instance 'klacksax :source source)) + (when document-events + (sax:start-document handler)) + (labels ((recurse () + (klacks:serialize-event source handler) + (loop + (let ((key (klacks:peek source))) + (ecase key + (:start-element (recurse)) + (:end-element (return)) + ((:characters :comment :processing-instruction) + (klacks:serialize-event source handler))))) + (klacks:serialize-event source handler))) + (recurse)) + (when document-events + (sax:end-document handler))) + +(defun klacks:find-element (source &optional lname uri) + (loop + (multiple-value-bind (key current-uri current-lname current-qname) + (klacks:peek source) + (case key + ((nil) + (return nil)) + (:start-element + (when (and (eq key :start-element) + (or (null lname) + (equal lname (klacks:current-lname source))) + (or (null uri) + (equal uri (klacks:current-uri source)))) + (return + (values key current-uri current-lname current-qname))))) + (klacks:consume source)))) + +(defun klacks:find-event (source key) + (loop + (multiple-value-bind (this a b c) + (klacks:peek source) + (cond + ((null this) + (return nil)) + ((eq this key) + (return (values this a b c)))) + (klacks:consume source)))) + +(define-condition klacks-error (xml-parse-error) ()) + +(defun klacks-error (fmt &rest args) + (%error 'klacks-error + nil + (format nil "Klacks assertion failed: ~?" fmt args))) + +(defun klacks:expect (source key &optional u v w) + (multiple-value-bind (this a b c) + (klacks:peek source) + (unless (eq this key) (klacks-error "expected ~A but got ~A" key this)) + (when (and u (not (equal a u))) + (klacks-error "expected ~A but got ~A" u a)) + (when (and v (not (equal b v))) + (klacks-error "expected ~A but got ~A" v b)) + (when (and w (not (equal c w))) + (klacks-error "expected ~A but got ~A" w c)) + (values this a b c))) + +(defun klacks:skip (source key &optional a b c) + (klacks:expect source key a b c) + (klacks:consume source)) + +(defun invoke-expecting-element (fn source &optional lname uri) + (multiple-value-bind (key a b) + (klacks:peek source) + (unless (eq key :start-element) + (klacks-error "expected ~A but got ~A" (or lname "element") key)) + (when (and uri (not (equal a uri))) + (klacks-error "expected ~A but got ~A" uri a)) + (when (and lname (not (equal b lname))) + (klacks-error "expected ~A but got ~A" lname b)) + (multiple-value-prog1 + (funcall fn) + (klacks:skip source :end-element a b)))) + +(defmacro klacks:expecting-element ((source &optional lname uri) &body body) + `(invoke-expecting-element (lambda () ,@body) ,source ,lname ,uri)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/package.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/package.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,60 @@ +;;; -*- Mode: Lisp; readtable: runes; -*- +;;; (c) copyright 2007 David Lichteblau + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 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 +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library 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. + +(defpackage klacks + (:use) + (:export #:source + #:close-source + #:with-open-source + #:tapping-source + #:make-tapping-source + + #:peek + #:peek-value + #:peek-next + #:consume + + #:expect + #:skip + #:find-element + #:find-event + #:expecting-element + + #:map-attributes + #:list-attributes + #:get-attribute + #:current-uri + #:current-lname + #:current-qname + #:current-characters + #:current-cdata-section-p + #:map-current-namespace-declarations + + #:serialize-event + #:serialize-element + #:serialize-source + + #:klacks-error + + #:current-line-number + #:current-column-number + #:current-system-id + #:current-xml-base + + #:find-namespace-binding + #:decode-qname)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/tap-source.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/tap-source.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/klacks/tap-source.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,106 @@ +;;; -*- Mode: Lisp; readtable: runes; -*- +;;; (c) copyright 2007 David Lichteblau + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 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 +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library 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. + +(in-package :cxml) + +(defun klacks:make-tapping-source (upstream-source &optional sax-handler) + (make-instance 'klacks:tapping-source + :upstream-source upstream-source + :dribble-handler sax-handler)) + +(defclass klacks:tapping-source (klacks:source) + ((upstream-source :initarg :upstream-source :accessor upstream-source) + (dribble-handler :initarg :dribble-handler :accessor dribble-handler) + (seen-event-p :initform nil :accessor seen-event-p) + (document-done-p :initform nil :accessor document-done-p))) + +(defmethod initialize-instance :after ((instance klacks:tapping-source) &key) + (let ((s-p (make-instance 'klacksax :source (upstream-source instance)))) + (sax:register-sax-parser (dribble-handler instance) s-p))) + + +;;; event dribbling + +(defun maybe-dribble (source) + (unless (or (seen-event-p source) (document-done-p source)) + (when (eq (klacks:peek (upstream-source source)) :end-document) + (setf (document-done-p source) t)) + (klacks:serialize-event (upstream-source source) + (dribble-handler source) + :consume nil) + (setf (seen-event-p source) t))) + +(defmethod klacks:peek ((source klacks:tapping-source)) + (multiple-value-prog1 + (klacks:peek (upstream-source source)) + (maybe-dribble source))) + +(defmethod klacks:peek-value ((source klacks:tapping-source)) + (multiple-value-prog1 + (klacks:peek-value (upstream-source source)) + (maybe-dribble source))) + +(defmethod klacks:peek-next ((source klacks:tapping-source)) + (setf (seen-event-p source) nil) + (multiple-value-prog1 + (klacks:peek-next (upstream-source source)) + (maybe-dribble source))) + +(defmethod klacks:consume ((source klacks:tapping-source)) + (maybe-dribble source) + (multiple-value-prog1 + (klacks:consume (upstream-source source)) + (setf (seen-event-p source) nil))) + + +;;; loop through + +(defmethod klacks:close-source ((source klacks:tapping-source)) + (klacks:close-source (upstream-source source))) + +(defmethod klacks:map-attributes (fn (source klacks:tapping-source)) + (klacks:map-attributes fn (upstream-source source))) + +(defmethod klacks:map-current-namespace-declarations + (fn (source klacks:tapping-source)) + (klacks:map-current-namespace-declarations fn (upstream-source source))) + +(defmethod klacks:list-attributes ((source klacks:tapping-source)) + (klacks:list-attributes (upstream-source source))) + +(defmethod klacks:current-line-number ((source klacks:tapping-source)) + (klacks:current-line-number (upstream-source source))) + +(defmethod klacks:current-column-number ((source klacks:tapping-source)) + (klacks:current-column-number (upstream-source source))) + +(defmethod klacks:current-system-id ((source klacks:tapping-source)) + (klacks:current-system-id (upstream-source source))) + +(defmethod klacks:current-xml-base ((source klacks:tapping-source)) + (klacks:current-xml-base (upstream-source source))) + +(defmethod klacks:current-cdata-section-p ((source klacks:tapping-source)) + (klacks:current-cdata-section-p (upstream-source source))) + +(defmethod klacks:find-namespace-binding + (prefix (source klacks:tapping-source)) + (klacks:find-namespace-binding prefix (upstream-source source))) + +(defmethod klacks:decode-qname (qname (source klacks:tapping-source)) + (klacks:decode-qname qname (upstream-source source))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/mlisp-patch.diff =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/mlisp-patch.diff 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/mlisp-patch.diff 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,68 @@ +--- xml/xml-parse.lisp ++++ xml/xml-parse.lisp +@@ -2497,20 +2497,20 @@ + (let ((input-var (gensym)) + (collect (gensym)) + (c (gensym))) +- `(LET ((,input-var ,input)) +- (MULTIPLE-VALUE-BIND (,res ,res-start ,res-end) +- (WITH-RUNE-COLLECTOR/RAW (,collect) +- (LOOP +- (LET ((,c (PEEK-RUNE ,input-var))) +- (COND ((EQ ,c :EOF) ++ `(let ((,input-var ,input)) ++ (multiple-value-bind (,res ,res-start ,res-end) ++ (with-rune-collector/raw (,collect) ++ (loop ++ (let ((,c (peek-rune ,input-var))) ++ (cond ((eq ,c :eof) + ;; xxx error message +- (RETURN)) +- ((FUNCALL ,predicate ,c) +- (RETURN)) ++ (return)) ++ ((funcall ,predicate ,c) ++ (return)) + (t + (,collect ,c) +- (CONSUME-RUNE ,input-var)))))) +- (LOCALLY ++ (consume-rune ,input-var)))))) ++ (locally + ,@body))))) + + (defun read-name-token (input) + + + +Index: xml/xml-name-rune-p.lisp +=================================================================== +RCS file: /project/cxml/cvsroot/cxml/xml/xml-name-rune-p.lisp,v +retrieving revision 1.2 +diff -r1.2 xml-name-rune-p.lisp +214,225c214,225 +< (DEFINLINE NAME-RUNE-P (RUNE) +< (SETF RUNE (RUNE-CODE RUNE)) +< (AND (<= 0 RUNE ,*max*) +< (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) +< (= 1 (SBIT ',(predicate-to-bv #'name-rune-p) +< (THE FIXNUM RUNE)))))) +< (DEFINLINE NAME-START-RUNE-P (RUNE) +< (SETF RUNE (RUNE-CODE RUNE)) +< (AND (<= 0 RUNE ,*MAX*) +< (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) +< (= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p) +< (THE FIXNUM RUNE)))))))) )))) +--- +> (definline name-rune-p (rune) +> (setf rune (rune-code rune)) +> (and (<= 0 rune ,*max*) +> (locally (declare (optimize (safety 0) (speed 3))) +> (= 1 (sbit ',(predicate-to-bv #'name-rune-p) +> (the fixnum rune)))))) +> (definline name-start-rune-p (rune) +> (setf rune (rune-code rune)) +> (and (<= 0 rune ,*max*) +> (locally (declare (optimize (safety 0) (speed 3))) +> (= 1 (sbit ',(predicate-to-bv #'name-start-rune-p) +> (the fixnum rune)))))))) )))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/Entries 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/Entries 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,12 @@ +/characters.lisp/1.5/Tue Dec 27 20:01:16 2005// +/definline.lisp/1.2/Mon Nov 28 22:33:35 2005// +/encodings-data.lisp/1.2/Sun Nov 27 17:19:12 2005// +/encodings.lisp/1.7/Sun Jul 22 19:59:26 2007// +/package.lisp/1.9/Sat Jun 30 21:22:24 2007// +/runes.lisp/1.4/Mon Nov 28 22:33:35 2005// +/stream-scl.lisp/1.1/Sat Jun 16 11:27:19 2007// +/syntax.lisp/1.2/Mon Nov 28 22:33:35 2005// +/utf8.lisp/1.3/Sat May 26 21:55:58 2007// +/xstream.lisp/1.6/Sun Sep 10 14:55:29 2006// +/ystream.lisp/1.6/Sat Jun 16 11:27:19 2007// +D Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/Repository 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/Repository 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +cxml/runes Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/Root 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/CVS/Root 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +:ext:dlichteblau@common-lisp.net:/project/cxml/cvsroot Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/characters.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/characters.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/characters.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,148 @@ +;;; copyright (c) 2004 knowledgeTools Int. GmbH +;;; Author of this version: David Lichteblau <david(a)knowledgetools.de> +;;; +;;; derived from runes.lisp, (c) copyright 1998,1999 by Gilbert Baumann +;;; +;;; License: Lisp-LGPL (See file COPYING for details). +;;; +;;; 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 to the Gnu Lesser General Public License" found in +;;; the file COPYING. +;;; +;;; 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. +;;; +;;; Version 2.1 of the GNU Lesser General Public License is in the file +;;; COPYING that was distributed with this file. If it is not present, +;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until +;;; superseded by a newer version) or write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(in-package :runes) + +(deftype rune () #-lispworks 'character #+lispworks 'lw:simple-char) +(deftype rod () '(vector rune)) +(deftype simple-rod () '(simple-array rune)) + +(definline rune (rod index) + (char rod index)) + +(defun (setf rune) (new rod index) + (setf (char rod index) new)) + +(definline %rune (rod index) + (aref (the simple-string rod) (the fixnum index))) + +(definline (setf %rune) (new rod index) + (setf (aref (the simple-string rod) (the fixnum index)) new)) + +(defun rod-capitalize (rod) + (string-upcase rod)) + +(definline code-rune (x) (code-char x)) +(definline rune-code (x) (char-code x)) + +(definline rune= (x y) + (char= x y)) + +(defun rune-downcase (rune) + (char-downcase rune)) + +(definline rune-upcase (rune) + (char-upcase rune)) + +(defun rune-upper-case-letter-p (rune) + (upper-case-p rune)) + +(defun rune-lower-case-letter-p (rune) + (lower-case-p rune)) + +(defun rune-equal (x y) + (char-equal x y)) + +(defun rod-downcase (rod) + (string-downcase rod)) + +(defun rod-upcase (rod) + (string-upcase rod)) + +(definline white-space-rune-p (char) + (or (char= char #\tab) + (char= char #.(code-char 10)) ;Linefeed + (char= char #.(code-char 13)) ;Carriage Return + (char= char #\space))) + +(definline digit-rune-p (char &optional (radix 10)) + (digit-char-p char radix)) + +(defun rod (x) + (cond + ((stringp x) x) + ((symbolp x) (string x)) + ((characterp x) (string x)) + ((vectorp x) (coerce x 'string)) + ((integerp x) (string (code-char x))) + (t (error "Cannot convert ~S to a ~S" x 'rod)))) + +(defun runep (x) + (characterp x)) + +(defun sloopy-rod-p (x) + (stringp x)) + +(defun rod= (x y) + (if (zerop (length x)) + (zerop (length y)) + (and (plusp (length y)) (string= x y)))) + +(defun rod-equal (x y) + (string-equal x y)) + +(definline make-rod (size) + (make-string size :element-type 'rune)) + +(defun char-rune (char) + char) + +(defun rune-char (rune &optional default) + (declare (ignore default)) + rune) + +(defun rod-string (rod &optional (default-char #\?)) + (declare (ignore default-char)) + rod) + +(defun string-rod (string) + string) + +;;;; + +(defun rune<= (rune &rest more-runes) + (loop + for (a b) on (cons rune more-runes) + while b + always (char<= a b))) + +(defun rune>= (rune &rest more-runes) + (loop + for (a b) on (cons rune more-runes) + while b + always (char>= a b))) + +(defun rodp (object) + (stringp object)) + +(defun rod-subseq (source start &optional (end (length source))) + (unless (stringp source) + (error "~S is not of type ~S." source 'rod)) + (subseq source start end)) + +(defun rod-subseq* (source start &optional (end (length source))) + (rod-subseq source start end)) + +(defun rod< (rod1 rod2) + (string< rod1 rod2)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/definline.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/definline.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/definline.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,63 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*- +;;; --------------------------------------------------------------------------- +;;; Title: definline +;;; Created: 1999-05-25 22:32 +;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1999 by Gilbert Baumann + +;;; 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 to the Gnu Lesser General Public License" found in +;;; the file COPYING. +;;; +;;; 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. +;;; +;;; Version 2.1 of the GNU Lesser General Public License is in the file +;;; COPYING that was distributed with this file. If it is not present, +;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until +;;; superseded by a newer version) or write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(in-package :runes) + +#-(or allegro openmcl) +(defmacro definline (name args &body body) + `(progn + (declaim (inline ,name)) + (defun ,name ,args .,body))) + +#+openmcl +(defmacro runes::definline (fun args &body body) + (if (consp fun) + `(defun ,fun ,args + ,@body) + `(progn + (defun ,fun ,args .,body) + (define-compiler-macro ,fun (&rest .args.) + (cons '(lambda ,args .,body) + .args.))))) + +#+allegro +(defmacro definline (fun args &body body) + (if (and (consp fun) (eq (car fun) 'setf)) + (let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")") + (symbol-package (cadr fun))))) + `(progn + (defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap)) + (definline ,fnam ,args .,body))) + (labels ((declp (x) + (and (consp x) (eq (car x) 'declare)))) + `(progn + (defun ,fun ,args .,body) + (define-compiler-macro ,fun (&rest .args.) + (cons '(lambda ,args + ,@(remove-if-not #'declp body) + (block ,fun + ,@(remove-if #'declp body))) + .args.)))))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/encodings-data.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/encodings-data.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/encodings-data.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,568 @@ +(in-package :runes-encoding) + +(progn + (add-name :us-ascii "ANSI_X3.4-1968") + (add-name :us-ascii "iso-ir-6") + (add-name :us-ascii "ANSI_X3.4-1986") + (add-name :us-ascii "ISO_646.irv:1991") + (add-name :us-ascii "ASCII") + (add-name :us-ascii "ISO646-US") + (add-name :us-ascii "US-ASCII") + (add-name :us-ascii "us") + (add-name :us-ascii "IBM367") + (add-name :us-ascii "cp367") + (add-name :us-ascii "csASCII") + + (add-name :iso-8859-1 "ISO_8859-1:1987") + (add-name :iso-8859-1 "iso-ir-100") + (add-name :iso-8859-1 "ISO_8859-1") + (add-name :iso-8859-1 "ISO-8859-1") + (add-name :iso-8859-1 "latin1") + (add-name :iso-8859-1 "l1") + (add-name :iso-8859-1 "IBM819") + (add-name :iso-8859-1 "CP819") + (add-name :iso-8859-1 "csISOLatin1") + + (add-name :iso-8859-2 "ISO_8859-2:1987") + (add-name :iso-8859-2 "iso-ir-101") + (add-name :iso-8859-2 "ISO_8859-2") + (add-name :iso-8859-2 "ISO-8859-2") + (add-name :iso-8859-2 "latin2") + (add-name :iso-8859-2 "l2") + (add-name :iso-8859-2 "csISOLatin2") + + (add-name :iso-8859-3 "ISO_8859-3:1988") + (add-name :iso-8859-3 "iso-ir-109") + (add-name :iso-8859-3 "ISO_8859-3") + (add-name :iso-8859-3 "ISO-8859-3") + (add-name :iso-8859-3 "latin3") + (add-name :iso-8859-3 "l3") + (add-name :iso-8859-3 "csISOLatin3") + + (add-name :iso-8859-4 "ISO_8859-4:1988") + (add-name :iso-8859-4 "iso-ir-110") + (add-name :iso-8859-4 "ISO_8859-4") + (add-name :iso-8859-4 "ISO-8859-4") + (add-name :iso-8859-4 "latin4") + (add-name :iso-8859-4 "l4") + (add-name :iso-8859-4 "csISOLatin4") + + (add-name :iso-8859-6 "ISO_8859-6:1987") + (add-name :iso-8859-6 "iso-ir-127") + (add-name :iso-8859-6 "ISO_8859-6") + (add-name :iso-8859-6 "ISO-8859-6") + (add-name :iso-8859-6 "ECMA-114") + (add-name :iso-8859-6 "ASMO-708") + (add-name :iso-8859-6 "arabic") + (add-name :iso-8859-6 "csISOLatinArabic") + + (add-name :iso-8859-7 "ISO_8859-7:1987") + (add-name :iso-8859-7 "iso-ir-126") + (add-name :iso-8859-7 "ISO_8859-7") + (add-name :iso-8859-7 "ISO-8859-7") + (add-name :iso-8859-7 "ELOT_928") + (add-name :iso-8859-7 "ECMA-118") + (add-name :iso-8859-7 "greek") + (add-name :iso-8859-7 "greek8") + (add-name :iso-8859-7 "csISOLatinGreek") + + (add-name :iso-8859-8 "ISO_8859-8:1988") + (add-name :iso-8859-8 "iso-ir-138") + (add-name :iso-8859-8 "ISO_8859-8") + (add-name :iso-8859-8 "ISO-8859-8") + (add-name :iso-8859-8 "hebrew") + (add-name :iso-8859-8 "csISOLatinHebrew") + + (add-name :iso-8859-5 "ISO_8859-5:1988") + (add-name :iso-8859-5 "iso-ir-144") + (add-name :iso-8859-5 "ISO_8859-5") + (add-name :iso-8859-5 "ISO-8859-5") + (add-name :iso-8859-5 "cyrillic") + (add-name :iso-8859-5 "csISOLatinCyrillic") + + (add-name :iso-8859-9 "ISO_8859-9:1989") + (add-name :iso-8859-9 "iso-ir-148") + (add-name :iso-8859-9 "ISO_8859-9") + (add-name :iso-8859-9 "ISO-8859-9") + (add-name :iso-8859-9 "latin5") + (add-name :iso-8859-9 "l5") + (add-name :iso-8859-9 "csISOLatin5") + + (add-name :iso-8859-15 "ISO_8859-15") + (add-name :iso-8859-15 "ISO-8859-15") + + (add-name :iso-8859-14 "ISO_8859-14") + (add-name :iso-8859-14 "ISO-8859-14") + + (add-name :koi8-r "KOI8-R") + (add-name :koi8-r "csKOI8R") + + (add-name :utf-8 "UTF-8") + + (add-name :utf-16 "UTF-16") + + (add-name :ucs-4 "ISO-10646-UCS-4") + (add-name :ucs-4 "UCS-4") + + (add-name :ucs-2 "ISO-10646-UCS-2") + (add-name :ucs-2 "UCS-2") ) + + +(progn + (define-encoding :iso-8859-1 + (make-simple-8-bit-encoding + :charset (find-charset :iso-8859-1))) + + (define-encoding :iso-8859-2 + (make-simple-8-bit-encoding + :charset (find-charset :iso-8859-2))) + + (define-encoding :iso-8859-3 + (make-simple-8-bit-encoding + :charset (find-charset :iso-8859-3))) + + (define-encoding :iso-8859-4 + (make-simple-8-bit-encoding + :charset (find-charset :iso-8859-4))) + + (define-encoding :iso-8859-5 + (make-simple-8-bit-encoding + :charset (find-charset :iso-8859-5))) + + (define-encoding :iso-8859-6 + (make-simple-8-bit-encoding + :charset (find-charset :iso-8859-6))) + + (define-encoding :iso-8859-7 + (make-simple-8-bit-encoding + :charset (find-charset :iso-8859-7))) + + (define-encoding :iso-8859-8 + (make-simple-8-bit-encoding + :charset (find-charset :iso-8859-8))) + + (define-encoding :iso-8859-14 + (make-simple-8-bit-encoding + :charset (find-charset :iso-8859-14))) + + (define-encoding :iso-8859-15 + (make-simple-8-bit-encoding + :charset (find-charset :iso-8859-15))) + + (define-encoding :koi8-r + (make-simple-8-bit-encoding + :charset (find-charset :koi8-r))) + + (define-encoding :utf-8 :utf-8) + ) + +(progn + (define-8-bit-charset :iso-8859-1 + #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007 + #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F + #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017 + #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F + #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 + #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F + #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037 + #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F + #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 + #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F + #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 + #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F + #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 + #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F + #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 + #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F + #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o24x |# #x00A0 #x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7 + #| #o25x |# #x00A8 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF + #| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7 + #| #o27x |# #x00B8 #x00B9 #x00BA #x00BB #x00BC #x00BD #x00BE #x00BF + #| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7 + #| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF + #| #o32x |# #x00D0 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7 + #| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x00DE #x00DF + #| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7 + #| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF + #| #o36x |# #x00F0 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7 + #| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x00FE #x00FF) + + (define-8-bit-charset :iso-8859-2 + #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007 + #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F + #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017 + #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F + #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 + #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F + #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037 + #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F + #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 + #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F + #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 + #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F + #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 + #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F + #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 + #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F + #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o24x |# #x00A0 #x0104 #x02D8 #x0141 #x00A4 #x013D #x015A #x00A7 + #| #o25x |# #x00A8 #x0160 #x015E #x0164 #x0179 #x00AD #x017D #x017B + #| #o26x |# #x00B0 #x0105 #x02DB #x0142 #x00B4 #x013E #x015B #x02C7 + #| #o27x |# #x00B8 #x0161 #x015F #x0165 #x017A #x02DD #x017E #x017C + #| #o30x |# #x0154 #x00C1 #x00C2 #x0102 #x00C4 #x0139 #x0106 #x00C7 + #| #o31x |# #x010C #x00C9 #x0118 #x00CB #x011A #x00CD #x00CE #x010E + #| #o32x |# #x0110 #x0143 #x0147 #x00D3 #x00D4 #x0150 #x00D6 #x00D7 + #| #o33x |# #x0158 #x016E #x00DA #x0170 #x00DC #x00DD #x0162 #x00DF + #| #o34x |# #x0155 #x00E1 #x00E2 #x0103 #x00E4 #x013A #x0107 #x00E7 + #| #o35x |# #x010D #x00E9 #x0119 #x00EB #x011B #x00ED #x00EE #x010F + #| #o36x |# #x0111 #x0144 #x0148 #x00F3 #x00F4 #x0151 #x00F6 #x00F7 + #| #o37x |# #x0159 #x016F #x00FA #x0171 #x00FC #x00FD #x0163 #x02D9) + + (define-8-bit-charset :iso-8859-3 + #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007 + #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F + #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017 + #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F + #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 + #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F + #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037 + #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F + #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 + #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F + #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 + #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F + #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 + #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F + #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 + #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F + #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o24x |# #x00A0 #x0126 #x02D8 #x00A3 #x00A4 #xFFFF #x0124 #x00A7 + #| #o25x |# #x00A8 #x0130 #x015E #x011E #x0134 #x00AD #xFFFF #x017B + #| #o26x |# #x00B0 #x0127 #x00B2 #x00B3 #x00B4 #x00B5 #x0125 #x00B7 + #| #o27x |# #x00B8 #x0131 #x015F #x011F #x0135 #x00BD #xFFFF #x017C + #| #o30x |# #x00C0 #x00C1 #x00C2 #xFFFF #x00C4 #x010A #x0108 #x00C7 + #| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF + #| #o32x |# #xFFFF #x00D1 #x00D2 #x00D3 #x00D4 #x0120 #x00D6 #x00D7 + #| #o33x |# #x011C #x00D9 #x00DA #x00DB #x00DC #x016C #x015C #x00DF + #| #o34x |# #x00E0 #x00E1 #x00E2 #xFFFF #x00E4 #x010B #x0109 #x00E7 + #| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF + #| #o36x |# #xFFFF #x00F1 #x00F2 #x00F3 #x00F4 #x0121 #x00F6 #x00F7 + #| #o37x |# #x011D #x00F9 #x00FA #x00FB #x00FC #x016D #x015D #x02D9) + + (define-8-bit-charset :iso-8859-4 + #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007 + #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F + #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017 + #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F + #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 + #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F + #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037 + #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F + #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 + #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F + #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 + #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F + #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 + #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F + #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 + #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F + #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o24x |# #x00A0 #x0104 #x0138 #x0156 #x00A4 #x0128 #x013B #x00A7 + #| #o25x |# #x00A8 #x0160 #x0112 #x0122 #x0166 #x00AD #x017D #x00AF + #| #o26x |# #x00B0 #x0105 #x02DB #x0157 #x00B4 #x0129 #x013C #x02C7 + #| #o27x |# #x00B8 #x0161 #x0113 #x0123 #x0167 #x014A #x017E #x014B + #| #o30x |# #x0100 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x012E + #| #o31x |# #x010C #x00C9 #x0118 #x00CB #x0116 #x00CD #x00CE #x012A + #| #o32x |# #x0110 #x0145 #x014C #x0136 #x00D4 #x00D5 #x00D6 #x00D7 + #| #o33x |# #x00D8 #x0172 #x00DA #x00DB #x00DC #x0168 #x016A #x00DF + #| #o34x |# #x0101 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x012F + #| #o35x |# #x010D #x00E9 #x0119 #x00EB #x0117 #x00ED #x00EE #x012B + #| #o36x |# #x0111 #x0146 #x014D #x0137 #x00F4 #x00F5 #x00F6 #x00F7 + #| #o37x |# #x00F8 #x0173 #x00FA #x00FB #x00FC #x0169 #x016B #x02D9) + + (define-8-bit-charset :iso-8859-5 + #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007 + #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F + #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017 + #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F + #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 + #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F + #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037 + #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F + #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 + #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F + #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 + #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F + #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 + #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F + #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 + #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F + #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o24x |# #x00A0 #x0401 #x0402 #x0403 #x0404 #x0405 #x0406 #x0407 + #| #o25x |# #x0408 #x0409 #x040A #x040B #x040C #x00AD #x040E #x040F + #| #o26x |# #x0410 #x0411 #x0412 #x0413 #x0414 #x0415 #x0416 #x0417 + #| #o27x |# #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E #x041F + #| #o30x |# #x0420 #x0421 #x0422 #x0423 #x0424 #x0425 #x0426 #x0427 + #| #o31x |# #x0428 #x0429 #x042A #x042B #x042C #x042D #x042E #x042F + #| #o32x |# #x0430 #x0431 #x0432 #x0433 #x0434 #x0435 #x0436 #x0437 + #| #o33x |# #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E #x043F + #| #o34x |# #x0440 #x0441 #x0442 #x0443 #x0444 #x0445 #x0446 #x0447 + #| #o35x |# #x0448 #x0449 #x044A #x044B #x044C #x044D #x044E #x044F + #| #o36x |# #x2116 #x0451 #x0452 #x0453 #x0454 #x0455 #x0456 #x0457 + #| #o37x |# #x0458 #x0459 #x045A #x045B #x045C #x00A7 #x045E #x045F) + + (define-8-bit-charset :iso-8859-6 + #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007 + #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F + #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017 + #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F + #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 + #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F + #| #o06x |# #x0660 #x0661 #x0662 #x0663 #x0664 #x0665 #x0666 #x0667 + #| #o07x |# #x0668 #x0669 #x003A #x003B #x003C #x003D #x003E #x003F + #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 + #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F + #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 + #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F + #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 + #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F + #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 + #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F + #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o24x |# #x00A0 #xFFFF #xFFFF #xFFFF #x00A4 #xFFFF #xFFFF #xFFFF + #| #o25x |# #xFFFF #xFFFF #xFFFF #xFFFF #x060C #x00AD #xFFFF #xFFFF + #| #o26x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o27x |# #xFFFF #xFFFF #xFFFF #x061B #xFFFF #xFFFF #xFFFF #x061F + #| #o30x |# #xFFFF #x0621 #x0622 #x0623 #x0624 #x0625 #x0626 #x0627 + #| #o31x |# #x0628 #x0629 #x062A #x062B #x062C #x062D #x062E #x062F + #| #o32x |# #x0630 #x0631 #x0632 #x0633 #x0634 #x0635 #x0636 #x0637 + #| #o33x |# #x0638 #x0639 #x063A #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o34x |# #x0640 #x0641 #x0642 #x0643 #x0644 #x0645 #x0646 #x0647 + #| #o35x |# #x0648 #x0649 #x064A #x064B #x064C #x064D #x064E #x064F + #| #o36x |# #x0650 #x0651 #x0652 #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o37x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF) + + (define-8-bit-charset :iso-8859-7 + #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007 + #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F + #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017 + #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F + #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 + #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F + #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037 + #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F + #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 + #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F + #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 + #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F + #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 + #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F + #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 + #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F + #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o24x |# #x00A0 #x02BD #x02BC #x00A3 #xFFFF #xFFFF #x00A6 #x00A7 + #| #o25x |# #x00A8 #x00A9 #xFFFF #x00AB #x00AC #x00AD #xFFFF #x2015 + #| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x0384 #x0385 #x0386 #x00B7 + #| #o27x |# #x0388 #x0389 #x038A #x00BB #x038C #x00BD #x038E #x038F + #| #o30x |# #x0390 #x0391 #x0392 #x0393 #x0394 #x0395 #x0396 #x0397 + #| #o31x |# #x0398 #x0399 #x039A #x039B #x039C #x039D #x039E #x039F + #| #o32x |# #x03A0 #x03A1 #xFFFF #x03A3 #x03A4 #x03A5 #x03A6 #x03A7 + #| #o33x |# #x03A8 #x03A9 #x03AA #x03AB #x03AC #x03AD #x03AE #x03AF + #| #o34x |# #x03B0 #x03B1 #x03B2 #x03B3 #x03B4 #x03B5 #x03B6 #x03B7 + #| #o35x |# #x03B8 #x03B9 #x03BA #x03BB #x03BC #x03BD #x03BE #x03BF + #| #o36x |# #x03C0 #x03C1 #x03C2 #x03C3 #x03C4 #x03C5 #x03C6 #x03C7 + #| #o37x |# #x03C8 #x03C9 #x03CA #x03CB #x03CC #x03CD #x03CE #xFFFF) + + (define-8-bit-charset :iso-8859-8 + #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007 + #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F + #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017 + #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F + #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 + #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F + #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037 + #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F + #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 + #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F + #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 + #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F + #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 + #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F + #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 + #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F + #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o24x |# #x00A0 #xFFFF #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7 + #| #o25x |# #x00A8 #x00A9 #x00D7 #x00AB #x00AC #x00AD #x00AE #x203E + #| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7 + #| #o27x |# #x00B8 #x00B9 #x00F7 #x00BB #x00BC #x00BD #x00BE #xFFFF + #| #o30x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o31x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o32x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o33x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #x2017 + #| #o34x |# #x05D0 #x05D1 #x05D2 #x05D3 #x05D4 #x05D5 #x05D6 #x05D7 + #| #o35x |# #x05D8 #x05D9 #x05DA #x05DB #x05DC #x05DD #x05DE #x05DF + #| #o36x |# #x05E0 #x05E1 #x05E2 #x05E3 #x05E4 #x05E5 #x05E6 #x05E7 + #| #o37x |# #x05E8 #x05E9 #x05EA #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF) + + (define-8-bit-charset :iso-8859-9 + #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007 + #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F + #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017 + #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F + #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 + #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F + #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037 + #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F + #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 + #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F + #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 + #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F + #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 + #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F + #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 + #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F + #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o24x |# #x00A0 #x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7 + #| #o25x |# #x00A8 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF + #| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7 + #| #o27x |# #x00B8 #x00B9 #x00BA #x00BB #x00BC #x00BD #x00BE #x00BF + #| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7 + #| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF + #| #o32x |# #x011E #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7 + #| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x0130 #x015E #x00DF + #| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7 + #| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF + #| #o36x |# #x011F #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7 + #| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x0131 #x015F #x00FF) + + (define-8-bit-charset :iso-8859-14 + #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007 + #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F + #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017 + #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F + #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 + #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F + #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037 + #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F + #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 + #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F + #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 + #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F + #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 + #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F + #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 + #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F + #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o24x |# #x00A0 #x1E02 #x1E03 #x00A3 #x010A #x010B #x1E0A #x00A7 + #| #o25x |# #x1E80 #x00A9 #x1E82 #x1E0B #x1EF2 #x00AD #x00AE #x0178 + #| #o26x |# #x1E1E #x1E1F #x0120 #x0121 #x1E40 #x1E41 #x00B6 #x1E56 + #| #o27x |# #x1E81 #x1E57 #x1E83 #x1E60 #x1EF3 #x1E84 #x1E85 #x1E61 + #| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7 + #| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF + #| #o32x |# #x0174 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x1E6A + #| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x0176 #x00DF + #| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7 + #| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF + #| #o36x |# #x0175 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x1E6B + #| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x0177 #x00FF) + + (define-8-bit-charset :iso-8859-15 + #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007 + #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F + #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017 + #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F + #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 + #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F + #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037 + #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F + #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 + #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F + #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 + #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F + #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 + #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F + #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 + #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F + #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF + #| #o24x |# #x00A0 #x00A1 #x00A2 #x00A3 #x20AC #x00A5 #x0160 #x00A7 + #| #o25x |# #x0161 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF + #| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x017D #x00B5 #x00B6 #x00B7 + #| #o27x |# #x017E #x00B9 #x00BA #x00BB #x0152 #x0153 #x0178 #x00BF + #| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7 + #| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF + #| #o32x |# #x00D0 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7 + #| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x00DE #x00DF + #| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7 + #| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF + #| #o36x |# #x00F0 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7 + #| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x00FE #x00FF) + + (define-8-bit-charset :koi8-r + #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007 + #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F + #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017 + #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F + #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027 + #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F + #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037 + #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F + #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047 + #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F + #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057 + #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F + #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067 + #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F + #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077 + #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F + #| #o20x |# #x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524 + #| #o21x |# #x252C #x2534 #x253C #x2580 #x2584 #x2588 #x258C #x2590 + #| #o22x |# #x2591 #x2592 #x2593 #x2320 #x25A0 #x2219 #x221A #x2248 + #| #o23x |# #x2264 #x2265 #x00A0 #x2321 #x00B0 #x00B2 #x00B7 #x00F7 + #| #o24x |# #x2550 #x2551 #x2552 #x0451 #x2553 #x2554 #x2555 #x2556 + #| #o25x |# #x2557 #x2558 #x2559 #x255A #x255B #x255C #x255D #x255E + #| #o26x |# #x255F #x2560 #x2561 #x0401 #x2562 #x2563 #x2564 #x2565 + #| #o27x |# #x2566 #x2567 #x2568 #x2569 #x256A #x256B #x256C #x00A9 + #| #o30x |# #x044E #x0430 #x0431 #x0446 #x0434 #x0435 #x0444 #x0433 + #| #o31x |# #x0445 #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E + #| #o32x |# #x043F #x044F #x0440 #x0441 #x0442 #x0443 #x0436 #x0432 + #| #o33x |# #x044C #x044B #x0437 #x0448 #x044D #x0449 #x0447 #x044A + #| #o34x |# #x042E #x0410 #x0411 #x0426 #x0414 #x0415 #x0424 #x0413 + #| #o35x |# #x0425 #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E + #| #o36x |# #x041F #x042F #x0420 #x0421 #x0422 #x0423 #x0416 #x0412 + #| #o37x |# #x042C #x042B #x0417 #x0428 #x042D #x0429 #x0427 #x042A) + ) + Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/encodings.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/encodings.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/encodings.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,396 @@ +(in-package :runes-encoding) + +(define-condition encoding-error (simple-error) ()) + +(defun xerror (fmt &rest args) + (error 'encoding-error :format-control fmt :format-arguments args)) + +;;;; --------------------------------------------------------------------------- +;;;; Encoding names +;;;; + +(defvar *names* (make-hash-table :test #'eq)) + +(defun canon-name (string) + (with-output-to-string (bag) + (map nil (lambda (ch) + (cond ((char= ch #\_) (write-char #\- bag)) + (t (write-char (char-upcase ch) bag)))) + string))) + +(defun canon-name-2 (string) + (with-output-to-string (bag) + (map nil (lambda (ch) + (cond ((char= ch #\_)) + ((char= ch #\-)) + (t (write-char (char-upcase ch) bag)))) + string))) + +(defmethod encoding-names ((encoding symbol)) + (gethash encoding *names*)) + +(defmethod (setf encoding-names) (new-value (encoding symbol)) + (setf (gethash encoding *names*) new-value)) + +(defun add-name (encoding name) + (pushnew (canon-name name) (encoding-names encoding) :test #'string=)) + +(defun resolve-name (string) + (cond ((symbolp string) + string) + (t + (setq string (canon-name string)) + (or + (block nil + (maphash (lambda (x y) + (when (member string y :test #'string=) + (return x))) + *names*) + nil) + (block nil + (maphash (lambda (x y) + (when (member string y + :test #'(lambda (x y) + (string= (canon-name-2 x) + (canon-name-2 y)))) + (return x))) + *names*) + nil))))) + +;;;; --------------------------------------------------------------------------- +;;;; Encodings +;;;; + +(defvar *encodings* (make-hash-table :test #'eq)) + +(defmacro define-encoding (name init-form) + `(progn + (setf (gethash ',name *encodings*) + (list nil (lambda () ,init-form))) + ',name)) + +(defun find-encoding (name) + (let ((x (gethash (resolve-name name) *encodings*))) + (and x + (or (first x) + (setf (first x) (funcall (second x))))))) + +(defclass encoding () ()) + +(defclass simple-8-bit-encoding (encoding) + ((table :initarg :table))) + +(defun make-simple-8-bit-encoding (&key charset) + (make-instance 'simple-8-bit-encoding + :table (coerce (to-unicode-table charset) '(simple-array (unsigned-byte 16) (256))))) + +;;;;;;; + +(defmacro fx-op (op &rest xs) + `(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))) +(defmacro fx-pred (op &rest xs) + `(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))) + +(defmacro %+ (&rest xs) `(fx-op + ,@xs)) +(defmacro %- (&rest xs) `(fx-op - ,@xs)) +(defmacro %* (&rest xs) `(fx-op * ,@xs)) +(defmacro %/ (&rest xs) `(fx-op floor ,@xs)) +(defmacro %and (&rest xs) `(fx-op logand ,@xs)) +(defmacro %ior (&rest xs) `(fx-op logior ,@xs)) +(defmacro %xor (&rest xs) `(fx-op logxor ,@xs)) +(defmacro %ash (&rest xs) `(fx-op ash ,@xs)) +(defmacro %mod (&rest xs) `(fx-op mod ,@xs)) + +(defmacro %= (&rest xs) `(fx-pred = ,@xs)) +(defmacro %<= (&rest xs) `(fx-pred <= ,@xs)) +(defmacro %>= (&rest xs) `(fx-pred >= ,@xs)) +(defmacro %< (&rest xs) `(fx-pred < ,@xs)) +(defmacro %> (&rest xs) `(fx-pred > ,@xs)) + +;;; Decoders + +;; The decoders share a common signature: +;; +;; DECODE input input-start input-end +;; output output-start output-end +;; eof-p +;; -> first-not-written ; first-not-read +;; +;; These decode functions should decode as much characters off `input' +;; into the `output' as possible and return the indexes to the first +;; not read and first not written element of `input' and `output' +;; respectively. If there are not enough bytes in `input' to decode a +;; full character, decoding shold be abandomed; the caller has to +;; ensure that the remaining bytes of `input' are passed to the +;; decoder again with more bytes appended. +;; +;; `eof-p' now in turn indicates, if the given input sequence, is all +;; the producer does have and might be used to produce error messages +;; in case of incomplete codes or decided what to do. +;; +;; Decoders are expected to handle the various CR/NL conventions and +;; canonicalize each end of line into a single NL rune (#xA) in good +;; old Lisp tradition. +;; + +;; TODO: change this to an encoding class, which then might carry +;; additional state. Stateless encodings could been represented by +;; keywords. e.g. +;; +;; defmethod DECODE-SEQUENCE ((encoding (eql :utf-8)) ...) +;; + +(defmethod decode-sequence ((encoding (eql :utf-16-big-endian)) + in in-start in-end out out-start out-end eof?) + ;; -> new wptr, new rptr + (let ((wptr out-start) + (rptr in-start)) + (loop + (when (%= wptr out-end) + (return)) + (when (>= (%+ rptr 1) in-end) + (return)) + (let ((hi (aref in rptr)) + (lo (aref in (%+ 1 rptr)))) + (setf rptr (%+ 2 rptr)) + ;; FIXME: Wenn wir hier ein Surrogate sehen, muessen wir das naechste + ;; Zeichen abwarten und nachgucken, dass nicht etwa die andere + ;; Haelfte fehlt! + (let ((x (logior (ash hi 8) lo))) + (when (or (eql x #xFFFE) (eql x #xFFFF)) + (xerror "not a valid code point: #x~X" x)) + (setf (aref out wptr) x)) + (setf wptr (%+ 1 wptr)))) + (values wptr rptr))) + +(defmethod decode-sequence ((encoding (eql :utf-16-little-endian)) + in in-start in-end out out-start out-end eof?) + ;; -> new wptr, new rptr + (let ((wptr out-start) + (rptr in-start)) + (loop + (when (%= wptr out-end) + (return)) + (when (>= (%+ rptr 1) in-end) + (return)) + (let ((lo (aref in (%+ 0 rptr))) + (hi (aref in (%+ 1 rptr)))) + (setf rptr (%+ 2 rptr)) + ;; FIXME: Wenn wir hier ein Surrogate sehen, muessen wir das naechste + ;; Zeichen abwarten und nachgucken, dass nicht etwa die andere + ;; Haelfte fehlt! + (let ((x (logior (ash hi 8) lo))) + (when (or (eql x #xFFFE) (eql x #xFFFF)) + (xerror "not a valid code point: #x~X" x)) + (setf (aref out wptr) x)) + (setf wptr (%+ 1 wptr)))) + (values wptr rptr))) + +(defmethod decode-sequence ((encoding (eql :utf-8)) + in in-start in-end out out-start out-end eof?) + (declare (optimize (speed 3) (safety 0)) + (type (simple-array (unsigned-byte 8) (*)) in) + (type (simple-array (unsigned-byte 16) (*)) out) + (type fixnum in-start in-end out-start out-end)) + (let ((wptr out-start) + (rptr in-start) + byte0) + (macrolet ((put (x) + `((lambda (x) + (when (or (<= #xD800 x #xDBFF) + (<= #xDC00 x #xDFFF)) + (xerror "surrogate encoded in UTF-8: #x~X." x)) + (cond ((or (%> x #x10FFFF) + (eql x #xFFFE) + (eql x #xFFFF)) + (xerror "not a valid code point: #x~X" x)) + ((%> x #xFFFF) + (setf (aref out (%+ 0 wptr)) (%+ #xD7C0 (ash x -10)) + (aref out (%+ 1 wptr)) (%ior #xDC00 (%and x #x3FF))) + (setf wptr (%+ wptr 2))) + (t + (setf (aref out wptr) x) + (setf wptr (%+ wptr 1))))) + ,x)) + (put1 (x) + `(progn + (setf (aref out wptr) ,x) + (setf wptr (%+ wptr 1))))) + (loop + (when (%= (+ wptr 1) out-end) (return)) + (when (%>= rptr in-end) (return)) + (setq byte0 (aref in rptr)) + (cond ((= byte0 #x0D) + ;; CR handling + ;; we need to know the following character + (cond ((>= (%+ rptr 1) in-end) + ;; no characters in buffer + (cond (eof? + ;; at EOF, pass it as NL + (put #x0A) + (setf rptr (%+ rptr 1))) + (t + ;; demand more characters + (return)))) + ((= (aref in (%+ rptr 1)) #x0A) + ;; we see CR NL, so forget this CR and the next NL will be + ;; inserted literally + (setf rptr (%+ rptr 1))) + (t + ;; singleton CR, pass it as NL + (put #x0A) + (setf rptr (%+ rptr 1))))) + + ((%<= #|#b00000000|# byte0 #b01111111) + (put1 byte0) + (setf rptr (%+ rptr 1))) + + ((%<= #|#b10000000|# byte0 #b10111111) + (xerror "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0) + (setf rptr (%+ rptr 1))) + + ((%<= #|#b11000000|# byte0 #b11011111) + (cond ((<= (%+ rptr 2) in-end) + (put + (dpb (ldb (byte 5 0) byte0) (byte 5 6) + (dpb (ldb (byte 6 0) (aref in (%+ rptr 1))) (byte 6 0) + 0))) + (setf rptr (%+ rptr 2))) + (t + (return)))) + + ((%<= #|#b11100000|# byte0 #b11101111) + (cond ((<= (%+ rptr 3) in-end) + (put + (dpb (ldb (byte 4 0) byte0) (byte 4 12) + (dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 6) + (dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 0) + 0)))) + (setf rptr (%+ rptr 3))) + (t + (return)))) + + ((%<= #|#b11110000|# byte0 #b11110111) + (cond ((<= (%+ rptr 4) in-end) + (put + (dpb (ldb (byte 3 0) byte0) (byte 3 18) + (dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 12) + (dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 6) + (dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 0) + 0))))) + (setf rptr (%+ rptr 4))) + (t + (return)))) + + ((%<= #|#b11111000|# byte0 #b11111011) + (cond ((<= (%+ rptr 5) in-end) + (put + (dpb (ldb (byte 2 0) byte0) (byte 2 24) + (dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 18) + (dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 12) + (dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 6) + (dpb (ldb (byte 6 0) (aref in (%+ 4 rptr))) (byte 6 0) + 0)))))) + (setf rptr (%+ rptr 5))) + (t + (return)))) + + ((%<= #|#b11111100|# byte0 #b11111101) + (cond ((<= (%+ rptr 6) in-end) + (put + (dpb (ldb (byte 1 0) byte0) (byte 1 30) + (dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 24) + (dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 18) + (dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 12) + (dpb (ldb (byte 6 0) (aref in (%+ 4 rptr))) (byte 6 6) + (dpb (ldb (byte 6 0) (aref in (%+ 5 rptr))) (byte 6 0) + 0))))))) + (setf rptr (%+ rptr 6))) + (t + (return)))) + + (t + (xerror "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0)) ) )) + (values wptr rptr)) ) + +(defmethod encoding-p ((object (eql :utf-16-little-endian))) t) +(defmethod encoding-p ((object (eql :utf-16-big-endian))) t) +(defmethod encoding-p ((object (eql :utf-8))) t) + +(defmethod encoding-p ((object encoding)) t) + +(defmethod decode-sequence ((encoding simple-8-bit-encoding) + in in-start in-end + out out-start out-end + eof?) + (declare (optimize (speed 3) (safety 0)) + (type (simple-array (unsigned-byte 8) (*)) in) + (type (simple-array (unsigned-byte 16) (*)) out) + (type fixnum in-start in-end out-start out-end)) + (let ((wptr out-start) + (rptr in-start) + (byte 0) + (table (slot-value encoding 'table))) + (declare (type fixnum wptr rptr) + (type (unsigned-byte 8) byte) + (type (simple-array (unsigned-byte 16) (*)) table)) + (loop + (when (%= wptr out-end) (return)) + (when (%>= rptr in-end) (return)) + (setq byte (aref in rptr)) + (cond ((= byte #x0D) + ;; CR handling + ;; we need to know the following character + (cond ((>= (%+ rptr 1) in-end) + ;; no characters in buffer + (cond (eof? + ;; at EOF, pass it as NL + (setf (aref out wptr) #x0A) + (setf wptr (%+ wptr 1)) + (setf rptr (%+ rptr 1))) + (t + ;; demand more characters + (return)))) + ((= (aref in (%+ rptr 1)) #x0A) + ;; we see CR NL, so forget this CR and the next NL will be + ;; inserted literally + (setf rptr (%+ rptr 1))) + (t + ;; singleton CR, pass it as NL + (setf (aref out wptr) #x0A) + (setf wptr (%+ wptr 1)) + (setf rptr (%+ rptr 1))))) + + (t + (setf (aref out wptr) (aref table byte)) + (setf wptr (%+ wptr 1)) + (setf rptr (%+ rptr 1))) )) + (values wptr rptr))) + +;;;; --------------------------------------------------------------------------- +;;;; Character sets +;;;; + +(defvar *charsets* (make-hash-table :test #'eq)) + +(defclass 8-bit-charset () + ((name :initarg :name) + (to-unicode-table + :initarg :to-unicode-table + :reader to-unicode-table))) + +(defmacro define-8-bit-charset (name &rest codes) + (assert (= 256 (length codes))) + `(progn + (setf (gethash ',name *charsets*) + (make-instance '8-bit-charset + :name ',name + :to-unicode-table + ',(make-array 256 + :element-type '(unsigned-byte 16) + :initial-contents codes))) + ',name)) + +(defun find-charset (name) + (or (gethash name *charsets*) + (xerror "There is no character set named ~S." name))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/package.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/package.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,99 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Generating a sane DEFPACKAGE for RUNES +;;; Created: 1999-05-25 +;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1999,2000 by Gilbert Baumann + +(in-package :cl-user) + +(defpackage :runes + (:use :cl #-scl :trivial-gray-streams) + (:export #:definline + + ;; runes.lisp + #:rune + #:rod + #:simple-rod + #:%rune + #:rod-capitalize + #:code-rune + #:rune-code + #:rune-downcase + #:rune-upcase + #:rod-downcase + #:rod-upcase + #:white-space-rune-p + #:digit-rune-p + #:rune= + #:rune<= + #:rune>= + #:rune-equal + #:runep + #:sloopy-rod-p + #:rod= + #:rod-equal + #:make-rod + #:char-rune + #:rune-char + #:rod-string + #:string-rod + #:rod-subseq + #:rod< + + ;; xstream.lisp + #:xstream + #:make-xstream + #:make-rod-xstream + #:close-xstream + #:xstream-p + #:read-rune + #:peek-rune + #:fread-rune + #:fpeek-rune + #:consume-rune + #:unread-rune + #:xstream-position + #:xstream-line-number + #:xstream-column-number + #:xstream-plist + #:xstream-encoding + #:set-to-full-speed + #:xstream-name + + ;; ystream.lisp + #:ystream + #:close-ystream + #:write-rune + #:write-rod + #:ystream-column + #:make-octet-vector-ystream + #:make-octet-stream-ystream + #:make-rod-ystream + #+rune-is-character #:make-character-stream-ystream + ;; These don't make too much sense on Unicode-enabled, + ;; implementations but for those applications using them anyway, + ;; I have commented out the reader conditionals now: + ;; #+rune-is-integer + #:make-string-ystream/utf8 + ;; #+rune-is-integer + #:make-character-stream-ystream/utf8 + #:runes-to-utf8/adjustable-string + + #:rod-to-utf8-string + #:utf8-string-to-rod + #:make-octet-input-stream)) + +(defpackage :utf8-runes + (:use :cl) + (:export *utf8-runes-readtable* + #:rune #:rod #:simple-rod #:rod-string #:rod= #:make-rod + #:string-rod)) + +(defpackage :runes-encoding + (:use :cl :runes) + (:export + #:encoding-error + #:find-encoding + #:decode-sequence)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/runes.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/runes.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/runes.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,230 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RUNES; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Unicode strings (called RODs) +;;; Created: 1999-05-25 22:29 +;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1998,1999 by Gilbert Baumann + +;;; 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 to the Gnu Lesser General Public License" found in +;;; the file COPYING. +;;; +;;; 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. +;;; +;;; Version 2.1 of the GNU Lesser General Public License is in the file +;;; COPYING that was distributed with this file. If it is not present, +;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until +;;; superseded by a newer version) or write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;; Changes +;; +;; When Who What +;; ---------------------------------------------------------------------------- +;; 1999-08-15 GB - ROD=, ROD-EQUAL +;; RUNE<=, RUNE>= +;; MAKE-ROD, ROD-SUBSEQ +;; CHAR-RUNE, RUNE-CHAR, ROD-STRING, STRING-ROD +;; new functions +;; - Added rune reader +;; + +(in-package :runes) + +(deftype rune () '(unsigned-byte 16)) +(deftype rod () '(array rune (*))) +(deftype simple-rod () '(simple-array rune (*))) + +(definline rune (rod index) + (aref rod index)) + +(defun (setf rune) (new rod index) + (setf (aref rod index) new)) + +(definline %rune (rod index) + (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index))) + +(definline (setf %rune) (new rod index) + (setf (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)) new)) + +(defun rod-capitalize (rod) + (warn "~S is not implemented." 'rod-capitalize) + rod) + +(definline code-rune (x) x) +(definline rune-code (x) x) + +(definline rune= (x y) + (= x y)) + +(defun rune-downcase (rune) + (cond ((<= #x0041 rune #x005a) (+ rune #x20)) + ((= rune #x00d7) rune) + ((<= #x00c0 rune #x00de) (+ rune #x20)) + (t rune))) + +(definline rune-upcase (rune) + (cond ((<= #x0061 rune #x007a) (- rune #x20)) + ((= rune #x00f7) rune) + ((<= #x00e0 rune #x00fe) (- rune #x20)) + (t rune))) + +(defun rune-upper-case-letter-p (rune) + (or (<= #x0041 rune #x005a) (<= #x00c0 rune #x00de))) + +(defun rune-lower-case-letter-p (rune) + (or (<= #x0061 rune #x007a) (<= #x00e0 rune #x00fe) + (= rune #x00d7))) + + +(defun rune-equal (x y) + (rune= (rune-upcase x) (rune-upcase y))) + +(defun rod-downcase (rod) + ;; FIXME + (map '(simple-array (unsigned-byte 16) (*)) #'rune-downcase rod)) + +(defun rod-upcase (rod) + ;; FIXME + (map '(simple-array (unsigned-byte 16) (*)) #'rune-upcase rod)) + +(definline white-space-rune-p (char) + (or (= char 9) ;TAB + (= char 10) ;Linefeed + (= char 13) ;Carriage Return + (= char 32))) ;Space + +(definline digit-rune-p (char &optional (radix 10)) + (cond ((<= #.(char-code #\0) char #.(char-code #\9)) + (and (< (- char #.(char-code #\0)) radix) + (- char #.(char-code #\0)))) + ((<= #.(char-code #\A) char #.(char-code #\Z)) + (and (< (- char #.(char-code #\A) -10) radix) + (- char #.(char-code #\A) -10))) + ((<= #.(char-code #\a) char #.(char-code #\z)) + (and (< (- char #.(char-code #\a) -10) radix) + (- char #.(char-code #\a) -10))) )) + +(defun rod (x) + (cond ((stringp x) (map 'rod #'char-code x)) + ((symbolp x) (rod (string x))) + ((characterp x) (rod (string x))) + ((vectorp x) (coerce x 'rod)) + ((integerp x) (map 'rod #'identity (list x))) + (t (error "Cannot convert ~S to a ~S" x 'rod)))) + +(defun runep (x) + (and (integerp x) + (<= 0 x #xFFFF))) + +(defun sloopy-rod-p (x) + (and (not (stringp x)) + (vectorp x) + (every #'runep x))) + +(defun rod= (x y) + (and (= (length x) (length y)) + (dotimes (i (length x) t) + (unless (rune= (rune x i) (rune y i)) + (return nil))))) + +(defun rod-equal (x y) + (and (= (length x) (length y)) + (dotimes (i (length x) t) + (unless (rune-equal (rune x i) (rune y i)) + (return nil))))) + +(definline make-rod (size) + (make-array size :element-type 'rune)) + +(defun char-rune (char) + (code-rune (char-code char))) + +(defparameter *invalid-rune* nil ;;#\? + "Rune to use as a replacement in RUNE-CHAR and ROD-STRING for runes not + representable as characters. If NIL, an error is signalled instead.") + +(defun rune-char (rune &optional (default *invalid-rune*)) + (or (if (>= rune char-code-limit) + default + (or (code-char rune) default)) + (error "rune cannot be represented as a character: ~A" rune))) + +(defun rod-string (rod &optional (default-char *invalid-rune*)) + (map 'string (lambda (x) (rune-char x default-char)) rod)) + +(defun string-rod (string) + (let* ((n (length string)) + (res (make-rod n))) + (dotimes (i n) + (setf (%rune res i) (char-rune (char string i)))) + res)) + +;;;; + +(defun rune<= (rune &rest more-runes) + (apply #'<= rune more-runes)) + +(defun rune>= (rune &rest more-runes) + (apply #'>= rune more-runes)) + +(defun rodp (object) + (typep object 'rod)) + +(defun rod-subseq (source start &optional (end (length source))) + (unless (rodp source) + (error "~S is not of type ~S." source 'rod)) + (unless (and (typep start 'fixnum) (>= start 0)) + (error "~S is not a non-negative fixnum." start)) + (unless (and (typep end 'fixnum) (>= end start)) + (error "END argument, ~S, is not a fixnum no less than START, ~S." end start)) + (when (> start (length source)) + (error "START argument, ~S, should be no greater than length of rod." start)) + (when (> end (length source)) + (error "END argument, ~S, should be no greater than length of rod." end)) + (locally + (declare (type rod source) + (type fixnum start end)) + (let ((res (make-rod (- end start)))) + (declare (type rod res)) + (do ((i (- (- end start) 1) (the fixnum (- i 1)))) + ((< i 0) res) + (declare (type fixnum i)) + (setf (%rune res i) (%rune source (the fixnum (+ i start)))))))) + +(defun rod-subseq* (source start &optional (end (length source))) + (unless (and (typep start 'fixnum) (>= start 0)) + (error "~S is not a non-negative fixnum." start)) + (unless (and (typep end 'fixnum) (>= end start)) + (error "END argument, ~S, is not a fixnum no less than START, ~S." end start)) + (when (> start (length source)) + (error "START argument, ~S, should be no greater than length of rod." start)) + (when (> end (length source)) + (error "END argument, ~S, should be no greater than length of rod." end)) + (locally + (declare (type fixnum start end)) + (let ((res (make-rod (- end start)))) + (declare (type rod res)) + (do ((i (- (- end start) 1) (the fixnum (- i 1)))) + ((< i 0) res) + (declare (type fixnum i)) + (setf (%rune res i) (aref source (the fixnum (+ i start)))))))) + +(defun rod< (rod1 rod2) + (do ((i 0 (+ i 1))) + (nil) + (cond ((= i (length rod1)) + (return t)) + ((= i (length rod2)) + (return nil)) + ((< (aref rod1 i) (aref rod2 i)) + (return t)) + ((> (aref rod1 i) (aref rod2 i)) + (return nil))))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/stream-scl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/stream-scl.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/stream-scl.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,253 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; readtable: runes; Encoding: utf-8; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Fast streams +;;; Created: 1999-07-17 +;;; Author: Douglas Crosher +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; (c) copyright 2007 by Douglas Crosher + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 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 +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library 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. + +(in-package :runes) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *fast* '(optimize (speed 3) (safety 3)))) + +(deftype runes-encoding:encoding-error () + 'ext:character-conversion-error) + + +;;; xstream + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defclass xstream (ext:character-stream) + ((name :initarg :name :initform nil + :accessor xstream-name) + (column :initarg :column :initform 0) + (line :initarg :line :initform 1) + (unread-column :initarg :unread-column :initform 0))) + +(defclass eol-conversion-xstream (lisp::eol-conversion-input-stream xstream) + ()) + +) ; eval-when + +(defun make-eol-conversion-xstream (source-stream) + "Returns a character stream that conversion CR-LF pairs and lone CR + characters into single linefeed character." + (declare (type stream source-stream)) + (let ((stream (ext:make-eol-conversion-stream source-stream + :input t + :close-stream-p t))) + (change-class stream 'eol-conversion-xstream))) + +(definline xstream-p (stream) + (typep stream 'xstream)) + +(defun close-xstream (input) + (close input)) + +(definline read-rune (input) + (declare (type stream input) + (inline read-char) + #.*fast*) + (let ((char (read-char input nil :eof))) + (cond ((member char '(#\UFFFE #\UFFFF)) + ;; These characters are illegal within XML documents. + (simple-error 'ext:character-conversion-error + "~@<Illegal XML document character: ~S~:@>" char)) + ((eql char #\linefeed) + (setf (slot-value input 'unread-column) (slot-value input 'column)) + (setf (slot-value input 'column) 0) + (incf (the kernel:index (slot-value input 'line)))) + (t + (incf (the kernel:index (slot-value input 'column))))) + char)) + +(definline peek-rune (input) + (declare (type stream input) + (inline peek-char) + #.*fast*) + (peek-char nil input nil :eof)) + +(definline consume-rune (input) + (declare (type stream input) + (inline read-rune) + #.*fast*) + (read-rune input) + nil) + +(definline unread-rune (rune input) + (declare (type stream input) + (inline unread-char) + #.*fast*) + (unread-char rune input) + (cond ((eql rune #\linefeed) + (setf (slot-value input 'column) (slot-value input 'unread-column)) + (setf (slot-value input 'unread-column) 0) + (decf (the kernel:index (slot-value input 'line)))) + (t + (decf (the kernel:index (slot-value input 'column))))) + nil) + +(defun fread-rune (input) + (read-rune input)) + +(defun fpeek-rune (input) + (peek-rune input)) + +(defun xstream-position (input) + (file-position input)) + +(defun runes-encoding:find-encoding (encoding) + encoding) + +(defun make-xstream (os-stream &key name + (speed 8192) + (initial-speed 1) + (initial-encoding :guess)) + (declare (ignore speed)) + (assert (eql initial-speed 1)) + (assert (eq initial-encoding :guess)) + (let* ((stream (ext:make-xml-character-conversion-stream os-stream + :input t + :close-stream-p t)) + (xstream (make-eol-conversion-xstream stream))) + (setf (xstream-name xstream) name) + xstream)) + + +(defclass xstream-string-input-stream (lisp::string-input-stream xstream) + ()) + +(defun make-rod-xstream (string &key name) + (declare (type string string)) + (let ((stream (make-string-input-stream string))) + (change-class stream 'xstream-string-input-stream :name name))) + +;;; already at 'full speed' so just return the buffer size. +(defun set-to-full-speed (stream) + (length (ext:stream-in-buffer stream))) + +(defun xstream-speed (stream) + (length (ext:stream-in-buffer stream))) + +(defun xstream-line-number (stream) + (slot-value stream 'line)) + +(defun xstream-column-number (stream) + (slot-value stream 'column)) + +(defun xstream-encoding (stream) + (stream-external-format stream)) + +;;; the encoding will have already been detected, but it is checked against the +;;; declared encoding here. +(defun (setf xstream-encoding) (declared-encoding stream) + (let* ((initial-encoding (xstream-encoding stream)) + (canonical-encoding + (cond ((and (eq initial-encoding :utf-16le) + (member declared-encoding '(:utf-16 :utf16 :utf-16le :utf16le) + :test 'string-equal)) + :utf-16le) + ((and (eq initial-encoding :utf-16be) + (member declared-encoding '(:utf-16 :utf16 :utf-16be :utf16be) + :test 'string-equal)) + :utf-16be) + ((and (eq initial-encoding :ucs-4be) + (member declared-encoding '(:ucs-4 :ucs4 :ucs-4be :ucs4be) + :test 'string-equal)) + :ucs4-be) + ((and (eq initial-encoding :ucs-4le) + (member declared-encoding '(:ucs-4 :ucs4 :ucs-4le :ucs4le) + :test 'string-equal)) + :ucs4-le) + (t + declared-encoding)))) + (unless (string-equal initial-encoding canonical-encoding) + (warn "Unable to change xstream encoding from ~S to ~S (~S)~%" + initial-encoding declared-encoding canonical-encoding)) + declared-encoding)) + + +;;; ystream - a run output stream. + +(deftype ystream () 'stream) + +(defun ystream-column (stream) + (ext:line-column stream)) + +(definline write-rune (rune stream) + (declare (inline write-char)) + (write-char rune stream)) + +(defun write-rod (rod stream) + (declare (type rod rod) + (type stream stream)) + (write-string rod stream)) + +(defun make-rod-ystream () + (make-string-output-stream)) + +(defun close-ystream (stream) + (etypecase stream + (ext:string-output-stream + (get-output-stream-string stream)) + (ext:character-conversion-output-stream + (let ((target (slot-value stream 'stream))) + (close stream) + (if (typep target 'ext:byte-output-stream) + (ext:get-output-stream-bytes target) + stream))))) + +;;;; CHARACTER-STREAM-YSTREAM + +(defun make-character-stream-ystream (target-stream) + target-stream) + + +;;;; OCTET-VECTOR-YSTREAM + +(defun make-octet-vector-ystream () + (let ((target (ext:make-byte-output-stream))) + (ext:make-character-conversion-stream target :output t + :external-format :utf-8 + :close-stream-p t))) + +;;;; OCTET-STREAM-YSTREAM + +(defun make-octet-stream-ystream (os-stream) + (ext:make-character-conversion-stream os-stream :output t + :external-format :utf-8 + :close-stream-p t)) + + +;;;; helper functions + +(defun rod-to-utf8-string (rod) + (ext:make-string-from-bytes (ext:make-bytes-from-string rod :utf8) + :iso-8859-1)) + +(defun utf8-string-to-rod (str) + (let ((bytes (map '(vector (unsigned-byte 8)) #'char-code str))) + (ext:make-string-from-bytes bytes :utf-8))) + +(defun make-octet-input-stream (octets) + (ext:make-byte-input-stream octets)) + + Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/syntax.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/syntax.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/syntax.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,181 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RUNES; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Unicode strings (called RODs) +;;; Created: 1999-05-25 22:29 +;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1998,1999 by Gilbert Baumann + +;;; 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 to the Gnu Lesser General Public License" found in +;;; the file COPYING. +;;; +;;; 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. +;;; +;;; Version 2.1 of the GNU Lesser General Public License is in the file +;;; COPYING that was distributed with this file. If it is not present, +;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until +;;; superseded by a newer version) or write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;; Changes +;; +;; When Who What +;; ---------------------------------------------------------------------------- +;; 1999-08-15 GB - ROD=, ROD-EQUAL +;; RUNE<=, RUNE>= +;; MAKE-ROD, ROD-SUBSEQ +;; CHAR-RUNE, RUNE-CHAR, ROD-STRING, STRING-ROD +;; new functions +;; - Added rune reader +;; + +(in-package :runes) + +;;;; +;;;; RUNE Reader +;;;; + +;; Portable implementation of WHITE-SPACE-P with regard to the current +;; read table -- this is bit tricky. + +(defun rt-white-space-p (char) + (let ((stream (make-string-input-stream (string char)))) + (eq :eof (peek-char t stream nil :eof)))) + +(defun read-rune-name (input) + ;; the first char is unconditionally read + (let ((char0 (read-char input t nil t))) + (when (char= char0 #\\) + (setf char0 (read-char input t nil t))) + (with-output-to-string (res) + (write-char char0 res) + (do ((ch (peek-char nil input nil :eof t) (peek-char nil input nil :eof t))) + ((or (eq ch :eof) + (rt-white-space-p ch) + (multiple-value-bind (function non-terminating-p) (get-macro-character ch) + (and function (not non-terminating-p))))) + (write-char ch res) + (read-char input))))) ;consume this character + +(defun iso-10646-char-code (char) + (char-code char)) + +(defvar *rune-names* (make-hash-table :test #'equal) + "Hashtable, which maps all known rune names to rune codes; + Names are stored in uppercase.") + +(defun define-rune-name (name code) + (setf (gethash (string-upcase name) *rune-names*) code) + name) + +(defun lookup-rune-name (name) + (gethash (string-upcase name) *rune-names*)) + +(define-rune-name "null" #x0000) +(define-rune-name "space" #x0020) +(define-rune-name "newline" #x000A) +(define-rune-name "return" #x000D) +(define-rune-name "tab" #x0009) +(define-rune-name "page" #x000C) + +;; and just for fun: +(define-rune-name "euro" #x20AC) + +;; ASCII control characters +(define-rune-name "nul" #x0000) ;null +(define-rune-name "soh" #x0001) ;start of header +(define-rune-name "stx" #x0002) ;start of text +(define-rune-name "etx" #x0003) ;end of text +(define-rune-name "eot" #x0004) ;end of transmission +(define-rune-name "enq" #x0005) ; +(define-rune-name "ack" #x0006) ;acknowledge +(define-rune-name "bel" #x0007) ;bell +(define-rune-name "bs" #x0008) ;backspace +(define-rune-name "ht" #x0009) ;horizontal tab +(define-rune-name "lf" #X000A) ;line feed, new line +(define-rune-name "vt" #X000B) ;vertical tab +(define-rune-name "ff" #x000C) ;form feed +(define-rune-name "cr" #x000D) ;carriage return +(define-rune-name "so" #x000E) ;shift out +(define-rune-name "si" #x000F) ;shift in +(define-rune-name "dle" #x0010) ;device latch enable ? +(define-rune-name "dc1" #x0011) ;device control 1 +(define-rune-name "dc2" #x0012) ;device control 2 +(define-rune-name "dc3" #x0013) ;device control 3 +(define-rune-name "dc4" #x0014) ;device control 4 +(define-rune-name "nak" #x0015) ;negative acknowledge +(define-rune-name "syn" #x0016) ; +(define-rune-name "etb" #x0017) ; +(define-rune-name "can" #x0018) ; +(define-rune-name "em" #x0019) ;end of message +(define-rune-name "sub" #x001A) ; +(define-rune-name "esc" #x001B) ;escape +(define-rune-name "fs" #x001C) ;field separator ? +(define-rune-name "gs" #x001D) ;group separator +(define-rune-name "rs" #x001E) ; +(define-rune-name "us" #x001F) ; + +(define-rune-name "del" #x007F) ;delete + +;; iso-latin +(define-rune-name "nbsp" #x00A0) ;non breakable space +(define-rune-name "shy" #x00AD) ;soft hyphen + +(defun rune-from-read-name (name) + (code-rune + (cond ((= (length name) 1) + (iso-10646-char-code (char name 0))) + ((and (= (length name) 2) + (char= (char name 0) #\\)) + (iso-10646-char-code (char name 1))) + ((and (>= (length name) 3) + (char-equal (char name 0) #\u) + (char-equal (char name 1) #\+) + (every (lambda (x) (digit-char-p x 16)) (subseq name 2))) + (parse-integer name :start 2 :radix 16)) + ((lookup-rune-name name)) + (t + (error "Meaningless rune name ~S." name))))) + +(defun rune-reader (stream subchar arg) + subchar arg + (values (rune-from-read-name (read-rune-name stream)))) + +(set-dispatch-macro-character #\# #\/ 'rune-reader) + +;;; ROD ext syntax + +(defun rod-reader (stream subchar arg) + (declare (ignore arg)) + (rod + (with-output-to-string (bag) + (do ((c (read-char stream t nil t) + (read-char stream t nil t))) + ((char= c subchar)) + (cond ((char= c #\\) + (setf c (read-char stream t nil t)))) + (princ c bag))))) + +#-rune-is-character +(defun rod-printer (stream rod) + (princ #\# stream) + (princ #\" stream) + (loop for x across rod do + (cond ((or (rune= x #.(char-rune #\\)) + (rune= x #.(char-rune #\"))) + (princ #\\ stream) + (princ (code-char x) stream)) + ((< x char-code-limit) + (princ (code-char x) stream)) + (t + (format stream "\\u~4,'0X" x)))) + (princ #\" stream)) + +(set-dispatch-macro-character #\# #\" 'rod-reader) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/utf8.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/utf8.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/utf8.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,36 @@ +;;; copyright (c) 2005 David Lichteblau <david(a)lichteblau.com> +;;; License: Lisp-LGPL (See file COPYING for details). +;;; +;;; Rune emulation for the UTF-8-compatible DOM implementation. +;;; Used only with 8 bit characters on non-unicode Lisps. + +(in-package :utf8-runes) + +(deftype rune () 'character) +(deftype rod () '(vector rune)) +(deftype simple-rod () '(simple-array rune)) + +(defun rod= (r s) + (string= r s)) + +(defun rod-string (rod &optional default) + (declare (ignore default)) + rod) + +(defun string-rod (string) + string) + +(defun make-rod (size) + (make-string size :element-type 'rune)) + +(defun rune-reader (stream subchar arg) + (runes::rune-char (runes::rune-reader stream subchar arg))) + +(defun rod-reader (stream subchar arg) + (runes::rod-string (runes::rod-reader stream subchar arg))) + +(setf runes-system:*utf8-runes-readtable* + (let ((rt (copy-readtable))) + (set-dispatch-macro-character #\# #\/ 'rune-reader rt) + (set-dispatch-macro-character #\# #\" 'rod-reader rt) + rt)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/xstream.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/xstream.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/xstream.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,405 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; readtable: runes; Encoding: utf-8; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Fast streams +;;; Created: 1999-07-17 +;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1999 by Gilbert Baumann + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 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 +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library 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. + +(in-package :runes) + +;;; API +;; +;; MAKE-XSTREAM cl-stream &key name! speed initial-speed initial-encoding +;; [function] +;; MAKE-ROD-XSTREAM rod &key name [function] +;; CLOSE-XSTREAM xstream [function] +;; XSTREAM-P object [function] +;; +;; READ-RUNE xstream [macro] +;; PEEK-RUNE xstream [macro] +;; FREAD-RUNE xstream [function] +;; FPEEK-RUNE xstream [function] +;; CONSUME-RUNE xstream [macro] +;; UNREAD-RUNE rune xstream [function] +;; +;; XSTREAM-NAME xstream [accessor] +;; XSTREAM-POSITION xstream [function] +;; XSTREAM-LINE-NUMBER xstream [function] +;; XSTREAM-COLUMN-NUMBER xstream [function] +;; XSTREAM-PLIST xstream [accessor] +;; XSTREAM-ENCODING xstream [accessor] <-- be careful here. [*] +;; SET-TO-FULL-SPEED xstream [function] + +;; [*] switching the encoding on the fly is only possible when the +;; stream's buffer is empty; therefore to be able to switch the +;; encoding, while some runes are already read, set the stream's speed +;; to 1 initially (via the initial-speed argument for MAKE-XSTREAM) +;; and later set it to full speed. (The encoding of the runes +;; sequence, you fetch off with READ-RUNE is always UTF-16 though). +;; After switching the encoding, SET-TO-FULL-SPEED can be used to bump the +;; speed up to a full buffer length. + +;; An encoding is simply something, which provides the DECODE-SEQUENCE +;; method. + +;;; Controller protocol +;; +;; READ-OCTECTS sequence os-stream start end -> first-non-written +;; XSTREAM/CLOSE os-stream +;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *fast* '(optimize (speed 3) (safety 0)))) + +;; Let us first define fast fixnum arithmetric get rid of type +;; checks. (After all we know what we do here). + +(defmacro fx-op (op &rest xs) + `(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))) +(defmacro fx-pred (op &rest xs) + `(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))) + +(defmacro %+ (&rest xs) `(fx-op + ,@xs)) +(defmacro %= (&rest xs) `(fx-pred = ,@xs)) + +(deftype buffer-index () + `(unsigned-byte ,(integer-length array-total-size-limit))) + +(deftype buffer-byte () + `(unsigned-byte 16)) + +(deftype octet () + `(unsigned-byte 8)) + +;; The usage of a special marker for EOF is experimental and +;; considered unhygenic. + +(defconstant +end+ #xFFFF + "Special marker inserted into stream buffers to indicate end of buffered data.") + +(defvar +null-buffer+ (make-array 0 :element-type 'buffer-byte)) +(defvar +null-octet-buffer+ (make-array 0 :element-type 'octet)) + +(defstruct (xstream + (:constructor make-xstream/low) + (:copier nil) + (:print-function print-xstream)) + + ;;; Read buffer + + ;; the buffer itself + (buffer +null-buffer+ + :type (simple-array buffer-byte (*))) + ;; points to the next element of `buffer' containing the next rune + ;; about to be read. + (read-ptr 0 :type buffer-index) + ;; points to the first element of `buffer' not containing a rune to + ;; be read. + (fill-ptr 0 :type buffer-index) + + ;;; OS buffer + + ;; a scratch pad for READ-SEQUENCE + (os-buffer +null-octet-buffer+ + :type (simple-array octet (*))) + + ;; `os-left-start', `os-left-end' designate a region of os-buffer, + ;; which still contains some undecoded data. This is needed because + ;; of the DECODE-SEQUENCE protocol + (os-left-start 0 :type buffer-index) + (os-left-end 0 :type buffer-index) + + ;; How much to read each time + (speed 0 :type buffer-index) + + ;; Some stream object obeying to a certain protcol + os-stream + + ;; The external format + ;; (some object offering the ENCODING protocol) + (encoding :utf-8) + + ;;A STREAM-NAME object + (name nil) + + ;; a plist a struct keeps the hack away + (plist nil) + + ;; Stream Position + (line-number 1 :type integer) ;current line number + (line-start 0 :type integer) ;stream position the current line starts at + (buffer-start 0 :type integer) ;stream position the current buffer starts at + + ;; There is no need to maintain a column counter for each character + ;; read, since we can easily compute it from `line-start' and + ;; `buffer-start'. + ) + +(defun print-xstream (self sink depth) + (declare (ignore depth)) + (format sink "#<~S ~S>" (type-of self) (xstream-name self))) + +(defmacro read-rune (input) + "Read a single rune off the xstream `input'. In case of end of file :EOF + is returned." + `((lambda (input) + (declare (type xstream input) + #.*fast*) + (let ((rp (xstream-read-ptr input))) + (declare (type buffer-index rp)) + (let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input)) + rp))) + (declare (type buffer-byte ch)) + (setf (xstream-read-ptr input) (%+ rp 1)) + (cond ((%= ch +end+) + (the (or (member :eof) rune) + (xstream-underflow input))) + ((%= ch #x000A) ;line break + (account-for-line-break input) + (code-rune ch)) + (t + (code-rune ch)))))) + ,input)) + +(defmacro peek-rune (input) + "Peek a single rune off the xstream `input'. In case of end of file :EOF + is returned." + `((lambda (input) + (declare (type xstream input) + #.*fast*) + (let ((rp (xstream-read-ptr input))) + (declare (type buffer-index rp)) + (let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input)) + rp))) + (declare (type buffer-byte ch)) + (cond ((%= ch +end+) + (prog1 + (the (or (member :eof) rune) (xstream-underflow input)) + (setf (xstream-read-ptr input) 0))) + (t + (code-rune ch)))))) + ,input)) + +(defmacro consume-rune (input) + "Like READ-RUNE, but does not actually return the read rune." + `((lambda (input) + (declare (type xstream input) + #.*fast*) + (let ((rp (xstream-read-ptr input))) + (declare (type buffer-index rp)) + (let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input)) + rp))) + (declare (type buffer-byte ch)) + (setf (xstream-read-ptr input) (%+ rp 1)) + (when (%= ch +end+) + (xstream-underflow input)) + (when (%= ch #x000A) ;line break + (account-for-line-break input) ))) + nil) + ,input)) + +(definline unread-rune (rune input) + "Unread the last recently read rune; if there wasn't such a rune, you + deserve to lose." + (declare (ignore rune)) + (decf (xstream-read-ptr input)) + (when (rune= (peek-rune input) #/u+000A) ;was it a line break? + (unaccount-for-line-break input))) + +(defun fread-rune (input) + (read-rune input)) + +(defun fpeek-rune (input) + (peek-rune input)) + +;;; Line counting + +(defun account-for-line-break (input) + (declare (type xstream input)) + (incf (xstream-line-number input)) + (setf (xstream-line-start input) + (+ (xstream-buffer-start input) (xstream-read-ptr input)))) + +(defun unaccount-for-line-break (input) + ;; incomplete! + ;; We better use a traditional lookahead technique or forbid unread-rune. + (decf (xstream-line-number input))) + +;; User API: + +(defun xstream-position (input) + (+ (xstream-buffer-start input) (xstream-read-ptr input))) + +;; xstream-line-number is structure accessor + +(defun xstream-column-number (input) + (+ (- (xstream-position input) + (xstream-line-start input)) + 1)) + +;;; Underflow + +(defmethod xstream-underflow ((input xstream)) + (declare (type xstream input)) + ;; we are about to fill new data into the buffer, so we need to + ;; adjust buffer-start. + (incf (xstream-buffer-start input) + (- (xstream-fill-ptr input) 0)) + (let (n m) + ;; when there is something left in the os-buffer, we move it to + ;; the start of the buffer. + (setf m (- (xstream-os-left-end input) (xstream-os-left-start input))) + (unless (zerop m) + (replace (xstream-os-buffer input) (xstream-os-buffer input) + :start1 0 :end1 m + :start2 (xstream-os-left-start input) + :end2 (xstream-os-left-end input)) + ;; then we take care that the buffer is large enough to carry at + ;; least 100 bytes (a random number) + ;; + ;; david: was heisst da random? ich nehme an, dass 100 einfach + ;; ausreichend sein soll, um die laengste utf-8 bytesequenz oder die + ;; beiden utf-16 surrogates zu halten? dann ist 100 ja wohl dicke + ;; ausreichend und koennte in make-xstream ordentlich geprueft werden. + ;; oder was geht hier vor? + (unless (>= (length (xstream-os-buffer input)) 100) + (error "You lost"))) + (setf n + (read-octets (xstream-os-buffer input) (xstream-os-stream input) + m (min (1- (length (xstream-os-buffer input))) + (+ m (xstream-speed input))))) + (cond ((%= n 0) + (setf (xstream-read-ptr input) 0 + (xstream-fill-ptr input) n) + (setf (aref (xstream-buffer input) (xstream-fill-ptr input)) +end+) + :eof) + (t + (multiple-value-bind (fnw fnr) + (runes-encoding:decode-sequence + (xstream-encoding input) + (xstream-os-buffer input) 0 n + (xstream-buffer input) 0 (1- (length (xstream-buffer input))) + (= n m)) + (setf (xstream-os-left-start input) fnr + (xstream-os-left-end input) n + (xstream-read-ptr input) 0 + (xstream-fill-ptr input) fnw) + (setf (aref (xstream-buffer input) (xstream-fill-ptr input)) +end+) + (read-rune input)))))) + +;;; constructor + +(defun make-xstream (os-stream &key name + (speed 8192) + (initial-speed 1) + (initial-encoding :guess)) + ;; XXX if initial-speed isn't 1, encoding will me munged up + (assert (eql initial-speed 1)) + (multiple-value-bind (encoding preread) + (if (eq initial-encoding :guess) + (figure-encoding os-stream) + (values initial-encoding nil)) + (let ((osbuf (make-array speed :element-type '(unsigned-byte 8)))) + (replace osbuf preread) + (make-xstream/low + :buffer (let ((r (make-array speed :element-type 'buffer-byte))) + (setf (elt r 0) #xFFFF) + r) + :read-ptr 0 + :fill-ptr 0 + :os-buffer osbuf + :speed initial-speed + :os-stream os-stream + :os-left-start 0 + :os-left-end (length preread) + :encoding encoding + :name name)))) + +(defun make-rod-xstream (string &key name) + ;; XXX encoding is mis-handled by this kind of stream + (let ((n (length string))) + (let ((buffer (make-array (1+ n) :element-type 'buffer-byte))) + (declare (type (simple-array buffer-byte (*)) buffer)) + ;; copy the rod + (do ((i (1- n) (- i 1))) + ((< i 0)) + (declare (type fixnum i)) + (setf (aref buffer i) (rune-code (%rune string i)))) + (setf (aref buffer n) +end+) + ;; + (make-xstream/low :buffer buffer + :read-ptr 0 + :fill-ptr n + ;; :os-buffer nil + :speed 1 + :os-stream nil + :name name)))) + +(defmethod figure-encoding ((stream null)) + (values :utf-8 nil)) + +(defmethod figure-encoding ((stream stream)) + (let ((c0 (read-byte stream nil :eof))) + (cond ((eq c0 :eof) + (values :utf-8 nil)) + (t + (let ((c1 (read-byte stream nil :eof))) + (cond ((eq c1 :eof) + (values :utf-8 (list c0))) + (t + (cond ((and (= c0 #xFE) (= c1 #xFF)) (values :utf-16-big-endian nil)) + ((and (= c0 #xFF) (= c1 #xFE)) (values :utf-16-little-endian nil)) + (t + (values :utf-8 (list c0 c1))))))))))) + +;;; misc + +(defun close-xstream (input) + (xstream/close (xstream-os-stream input))) + +(defun set-to-full-speed (xstream) + (setf (xstream-speed xstream) (length (xstream-os-buffer xstream)))) + +;;; controller implementations + +(defmethod read-octets (sequence (stream stream) start end) + (#+CLISP ext:read-byte-sequence + #-CLISP read-sequence + sequence stream :start start :end end)) + +#+cmu +(defmethod read-octets :around (sequence (stream stream) start end) + ;; CMUCL <= 19a on non-SunOS accidentally triggers EFAULT in read(2) + ;; if SEQUENCE has been write protected by GC. Workaround: Touch all pages + ;; in SEQUENCE and make sure no GC happens between that and the read(2). + (ext::without-gcing + (loop for i from start below end + do (setf (elt sequence i) (elt sequence i))) + (call-next-method))) + +(defmethod read-octets (sequence (stream null) start end) + (declare (ignore sequence start end)) + 0) + +(defmethod xstream/close ((stream stream)) + (close stream)) + +(defmethod xstream/close ((stream null)) + nil) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/ystream.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/ystream.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes/ystream.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,297 @@ +;;; (c) 2005 David Lichteblau <david(a)lichteblau.com> +;;; License: Lisp-LGPL (See file COPYING for details). +;;; +;;; ystream (for lack of a better name): a rune output "stream" + +(in-package :runes) + +(defconstant +ystream-bufsize+ 1024) + +(defun make-ub8-array (n) + (make-array n :element-type '(unsigned-byte 8))) + +(defun make-ub16-array (n) + (make-array n :element-type '(unsigned-byte 16))) + +(defun make-buffer (&key (element-type '(unsigned-byte 8))) + (make-array 1 + :element-type element-type + :adjustable t + :fill-pointer 0)) + +(defmacro while (test &body body) + `(until (not ,test) ,@body)) + +(defmacro until (test &body body) + `(do () (,test) ,@body)) + +;;; ystream +;;; +- utf8-ystream +;;; | +- octet-vector-ystream +;;; | \- %stream-ystream +;;; | +- octet-stream-ystream +;;; | \- character-stream-ystream/utf8 +;;; | \- string-ystream/utf8 +;;; +- rod-ystream +;;; \-- character-stream-ystream + +(defstruct ystream + (column 0 :type integer) + (in-ptr 0 :type fixnum) + (in-buffer (make-rod +ystream-bufsize+) :type simple-rod)) + +(defstruct (utf8-ystream + (:include ystream) + (:conc-name "YSTREAM-")) + (out-buffer (make-ub8-array (* 6 +ystream-bufsize+)) + :type (simple-array (unsigned-byte 8) (*)))) + +(defstruct (%stream-ystream (:include utf8-ystream) (:conc-name "YSTREAM-")) + (os-stream nil)) + +(definline write-rune (rune ystream) + (let ((in (ystream-in-buffer ystream))) + (when (eql (ystream-in-ptr ystream) (length in)) + (flush-ystream ystream) + (setf in (ystream-in-buffer ystream))) + (setf (elt in (ystream-in-ptr ystream)) rune) + (incf (ystream-in-ptr ystream)) + (setf (ystream-column ystream) + (if (eql rune #/U+0010) 0 (1+ (ystream-column ystream)))) + rune)) + +(defmethod close-ystream :before ((ystream ystream)) + (flush-ystream ystream)) + + +;;;; UTF8-YSTREAM (abstract) + +(defmethod close-ystream ((ystream %stream-ystream)) + (ystream-os-stream ystream)) + +(defgeneric ystream-device-write (ystream buf nbytes)) + +(defmethod flush-ystream ((ystream utf8-ystream)) + (let ((ptr (ystream-in-ptr ystream))) + (when (plusp ptr) + (let* ((in (ystream-in-buffer ystream)) + (out (ystream-out-buffer ystream)) + (surrogatep (<= #xD800 (rune-code (elt in (1- ptr))) #xDBFF)) + n) + (when surrogatep + (decf ptr)) + (when (plusp ptr) + (setf n (runes-to-utf8 out in ptr)) + (ystream-device-write ystream out n) + (cond + (surrogatep + (setf (elt in 0) (elt in (1- ptr))) + (setf (ystream-in-ptr ystream) 1)) + (t + (setf (ystream-in-ptr ystream) 0)))))))) + +(defun write-rod (rod sink) + (loop for rune across rod do (write-rune rune sink))) + +(defun fast-push (new-element vector) + (vector-push-extend new-element vector (max 1 (array-dimension vector 0)))) + +(macrolet ((define-utf8-writer (name (byte &rest aux) result &body body) + `(defun ,name (out in n) + (let ((high-surrogate nil) + ,@aux) + (labels + ((write0 (,byte) + ,@body) + (write1 (r) + (cond + ((<= #x00000000 r #x0000007F) + (write0 r)) + ((<= #x00000080 r #x000007FF) + (write0 (logior #b11000000 (ldb (byte 5 6) r))) + (write0 (logior #b10000000 (ldb (byte 6 0) r)))) + ((<= #x00000800 r #x0000FFFF) + (write0 (logior #b11100000 (ldb (byte 4 12) r))) + (write0 (logior #b10000000 (ldb (byte 6 6) r))) + (write0 (logior #b10000000 (ldb (byte 6 0) r)))) + ((<= #x00010000 r #x001FFFFF) + (write0 (logior #b11110000 (ldb (byte 3 18) r))) + (write0 (logior #b10000000 (ldb (byte 6 12) r))) + (write0 (logior #b10000000 (ldb (byte 6 6) r))) + (write0 (logior #b10000000 (ldb (byte 6 0) r)))) + ((<= #x00200000 r #x03FFFFFF) + (write0 (logior #b11111000 (ldb (byte 2 24) r))) + (write0 (logior #b10000000 (ldb (byte 6 18) r))) + (write0 (logior #b10000000 (ldb (byte 6 12) r))) + (write0 (logior #b10000000 (ldb (byte 6 6) r))) + (write0 (logior #b10000000 (ldb (byte 6 0) r)))) + ((<= #x04000000 r #x7FFFFFFF) + (write0 (logior #b11111100 (ldb (byte 1 30) r))) + (write0 (logior #b10000000 (ldb (byte 6 24) r))) + (write0 (logior #b10000000 (ldb (byte 6 18) r))) + (write0 (logior #b10000000 (ldb (byte 6 12) r))) + (write0 (logior #b10000000 (ldb (byte 6 6) r))) + (write0 (logior #b10000000 (ldb (byte 6 0) r)))))) + (write2 (r) + (cond + ((<= #xD800 r #xDBFF) + (setf high-surrogate r)) + ((<= #xDC00 r #xDFFF) + (let ((q (logior (ash (- high-surrogate #xD7C0) 10) + (- r #xDC00)))) + (write1 q)) + (setf high-surrogate nil)) + (t + (write1 r))))) + (dotimes (j n) + (write2 (rune-code (elt in j))))) + ,result)))) + (define-utf8-writer runes-to-utf8 (x (i 0)) + i + (setf (elt out i) x) + (incf i)) + (define-utf8-writer runes-to-utf8/adjustable-string (x) + nil + (fast-push (code-char x) out))) + + +;;;; ROD-YSTREAM + +(defstruct (rod-ystream (:include ystream))) + +(defmethod flush-ystream ((ystream rod-ystream)) + (let* ((old (ystream-in-buffer ystream)) + (new (make-rod (* 2 (length old))))) + (replace new old) + (setf (ystream-in-buffer ystream) new))) + +(defmethod close-ystream ((ystream rod-ystream)) + (subseq (ystream-in-buffer ystream) 0 (ystream-in-ptr ystream))) + + +;;;; CHARACTER-STREAM-YSTREAM + +#+rune-is-character +(progn + (defstruct (character-stream-ystream + (:constructor make-character-stream-ystream (target-stream)) + (:include ystream) + (:conc-name "YSTREAM-")) + (target-stream nil)) + + (defmethod flush-ystream ((ystream character-stream-ystream)) + (write-string (ystream-in-buffer ystream) + (ystream-target-stream ystream) + :end (ystream-in-ptr ystream)) + (setf (ystream-in-ptr ystream) 0)) + + (defmethod close-ystream ((ystream character-stream-ystream)) + (ystream-target-stream ystream))) + + +;;;; OCTET-VECTOR-YSTREAM + +(defstruct (octet-vector-ystream + (:include utf8-ystream) + (:conc-name "YSTREAM-")) + (result (make-buffer))) + +(defmethod ystream-device-write ((ystream octet-vector-ystream) buf nbytes) + (let* ((result (ystream-result ystream)) + (start (length result)) + (size (array-dimension result 0))) + (while (> (+ start nbytes) size) + (setf size (* 2 size))) + (adjust-array result size :fill-pointer (+ start nbytes)) + (replace result buf :start1 start :end2 nbytes))) + +(defmethod close-ystream ((ystream octet-vector-ystream)) + (ystream-result ystream)) + + +;;;; OCTET-STREAM-YSTREAM + +(defstruct (octet-stream-ystream + (:include %stream-ystream) + (:constructor make-octet-stream-ystream (os-stream)) + (:conc-name "YSTREAM-"))) + +(defmethod ystream-device-write ((ystream octet-stream-ystream) buf nbytes) + (write-sequence buf (ystream-os-stream ystream) :end nbytes)) + + +;;;; CHARACTER-STREAM-YSTREAM/UTF8 + +;; #+rune-is-integer +(progn + (defstruct (character-stream-ystream/utf8 + (:constructor make-character-stream-ystream/utf8 (os-stream)) + (:include %stream-ystream) + (:conc-name "YSTREAM-"))) + + (defmethod ystream-device-write + ((ystream character-stream-ystream/utf8) buf nbytes) + (declare (type (simple-array (unsigned-byte 8) (*)) buf)) + (let ((out (ystream-os-stream ystream))) + (dotimes (x nbytes) + (write-char (code-char (elt buf x)) out))))) + + +;;;; STRING-YSTREAM/UTF8 + +;; #+rune-is-integer +(progn + (defstruct (string-ystream/utf8 + (:include character-stream-ystream/utf8 + (os-stream (make-string-output-stream))) + (:conc-name "YSTREAM-"))) + + (defmethod close-ystream ((ystream string-ystream/utf8)) + (get-output-stream-string (ystream-os-stream ystream)))) + + +;;;; helper functions + +(defun rod-to-utf8-string (rod) + (let ((out (make-buffer :element-type 'character))) + (runes-to-utf8/adjustable-string out rod (length rod)) + out)) + +(defun utf8-string-to-rod (str) + (let* ((bytes (map '(vector (unsigned-byte 8)) #'char-code str)) + (buffer (make-array (length bytes) :element-type '(unsigned-byte 16))) + (n (runes-encoding:decode-sequence + :utf-8 bytes 0 (length bytes) buffer 0 0 nil)) + (result (make-array n :element-type 'rune))) + (map-into result #'code-rune buffer) + result)) + +(defclass octet-input-stream + (trivial-gray-stream-mixin fundamental-binary-input-stream) + ((octets :initarg :octets) + (pos :initform 0))) + +(defmethod close ((stream octet-input-stream) &key abort) + (declare (ignore abort)) + (open-stream-p stream)) + +(defmethod stream-read-byte ((stream octet-input-stream)) + (with-slots (octets pos) stream + (if (>= pos (length octets)) + :eof + (prog1 + (elt octets pos) + (incf pos))))) + +(defmethod stream-read-sequence + ((stream octet-input-stream) sequence start end &key &allow-other-keys) + (with-slots (octets pos) stream + (let* ((length (min (- end start) (- (length octets) pos))) + (end1 (+ start length)) + (end2 (+ pos length))) + (replace sequence octets :start1 start :end1 end1 :start2 pos :end2 end2) + (setf pos end2) + end1))) + +(defun make-octet-input-stream (octets) + (make-instance 'octet-input-stream :octets octets)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes.asd =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes.asd 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/runes.asd 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,63 @@ +;;; XXX Die vielen verschiedenen Systeme hier sollten vielleicht +;;; Module eines grossen Systems CXML werden? + +(defpackage :runes-system + (:use :asdf :cl) + (:export #:*utf8-runes-readtable*)) + +(in-package :runes-system) + +(defvar *utf8-runes-readtable*) + +(defclass closure-source-file (cl-source-file) ()) + +#+sbcl +(defmethod perform :around ((o compile-op) (s closure-source-file)) + ;; shut up already. Correctness first. + (handler-bind ((sb-ext:compiler-note #'muffle-warning)) + (let (#+sbcl (*compile-print* nil)) + (call-next-method)))) + +#-(or rune-is-character rune-is-integer) +(progn + (format t "~&;;; Checking for wide character support...") + (force-output) + (pushnew (dotimes (x 65536 + (progn + (format t " ok, characters have at least 16 bits.~%") + :rune-is-character)) + (unless (or (<= #xD800 x #xDFFF) + (and (< x char-code-limit) (code-char x))) + (print (code-char x)) + (format t " no, reverting to octet strings.~%") + (return :rune-is-integer))) + *features*)) + +#-rune-is-character +(format t "~&;;; Building Closure with (UNSIGNED-BYTE 16) RUNES~%") + +#+rune-is-character +(format t "~&;;; Building Closure with CHARACTER RUNES~%") + +(defsystem :runes + :default-component-class closure-source-file + :pathname (merge-pathnames + "runes/" + (make-pathname :name nil :type nil :defaults *load-truename*)) + :serial t + :components + ((:file "package") + (:file "definline") + (:file runes + :pathname + #-rune-is-character "runes" + #+rune-is-character "characters") + #+rune-is-integer (:file "utf8") + (:file "syntax") + #-x&y-streams-are-stream (:file "encodings") + #-x&y-streams-are-stream (:file "encodings-data") + #-x&y-streams-are-stream (:file "xstream") + #-x&y-streams-are-stream (:file "ystream") + #+x&y-streams-are-stream (:file #+scl "stream-scl") + ) + :depends-on (#-scl :trivial-gray-streams)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/Entries 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/Entries 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,6 @@ +/domtest.lisp/1.18/Sat Jun 16 09:52:15 2007// +/misc.lisp/1.1/Sun Jul 22 19:59:27 2007// +/utf8domtest.diff/1.1/Tue Dec 27 01:35:16 2005// +/xmlconf-base.diff/1.1.1.1/Sun Mar 13 18:02:28 2005// +/xmlconf.lisp/1.16/Sun Jul 1 17:26:12 2007// +D Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/Repository 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/Repository 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +cxml/test Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/Root 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/CVS/Root 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +:ext:dlichteblau@common-lisp.net:/project/cxml/cvsroot Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/domtest.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/domtest.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/domtest.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,719 @@ +(defpackage :domtest + (:use :cl :cxml) + (:export #:run-all-tests)) +(defpackage :domtest-tests + (:use)) +(in-package :domtest) + + +;;;; allgemeine Hilfsfunktionen + +(defmacro string-case (keyform &rest clauses) + (let ((key (gensym "key"))) + `(let ((,key ,keyform)) + (declare (ignorable ,key)) + (cond + ,@(loop + for (keys . forms) in clauses + for test = (etypecase keys + (string `(string= ,key ,keys)) + (sequence `(find ,key ',keys :test 'string=)) + ((eql t) t)) + collect + `(,test ,@forms)))))) + +(defun rcurry (function &rest args) + (lambda (&rest more-args) + (apply function (append more-args args)))) + +(defmacro for ((&rest clauses) &rest body-forms) + `(%for ,clauses (progn ,@body-forms))) + +(defmacro for* ((&rest clauses) &rest body-forms) + `(%for* ,clauses (progn ,@body-forms))) + +(defmacro %for ((&rest clauses) body-form &rest finally-forms) + (for-aux 'for clauses body-form finally-forms)) + +(defmacro %for* ((&rest clauses) body-form &rest finally-forms) + (for-aux 'for* clauses body-form finally-forms)) + +(defmacro for-finish () + '(loop-finish)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun for-aux (kind clauses body-form finally-forms) + ` (loop ,@ (loop for firstp = t then nil + for %clauses = clauses then (rest %clauses) + for clause = (first %clauses) then (first %clauses) + while (and %clauses (listp clause)) + append (cons (ecase kind + (for (if firstp 'as 'and)) + (for* 'as)) + (if (= 2 (length clause)) + (list (first clause) '= (second clause)) + clause)) + into result + finally (return (append result %clauses))) + do (progn ,body-form) + finally (progn ,@finally-forms)))) + + +;;;; spezielle Hilfsfunktionen + +(defun tag-name (elt) + (runes:rod-string (dom:tag-name elt))) + +(defmacro with-attributes ((&rest attributes) element &body body) + (let ((e (gensym "element"))) + `(let* ((,e ,element) + ,@(mapcar (lambda (var) + `(,var (dom:get-attribute ,e ,(symbol-name var)))) + attributes)) + ,@body))) + +(defun map-child-elements (result-type fn element &key name) + (remove '#1=#:void + (map result-type + (lambda (node) + (if (and (eq (dom:node-type node) :element) + (or (null name) + (equal (tag-name node) name))) + (funcall fn node) + '#1#)) + (dom:child-nodes element)))) + +(defmacro do-child-elements ((var element &key name) &body body) + `(block nil + (map-child-elements nil (lambda (,var) ,@body) ,element :name ,name))) + +(defun find-child-element (name element) + (do-child-elements (child element :name name) + (return child))) + +(defun %intern (name) + (unless (stringp name) + (setf name (runes:rod-string name))) + (if (zerop (length name)) + nil + (intern name :domtest-tests))) + +(defun replace-studly-caps (str) + (unless (stringp str) + (setf str (runes:rod-string str))) + ;; s/([A-Z][a-z])/-\1/ + (with-output-to-string (out) + (with-input-from-string (in str) + (for ((c = (read-char in nil nil)) + (previous = nil then c) + (next = (peek-char nil in nil nil)) + :while c) + (when (and previous + (upper-case-p c) next (lower-case-p next) + (not (lower-case-p previous))) + (write-char #\- out)) + (write-char (char-downcase c) out) + (when (and (lower-case-p c) next (upper-case-p next)) + (write-char #\- out)))))) + +(defun intern-dom (name) + (setf name (replace-studly-caps name)) + (when (eq :foo :FOO) + (setf name (string-upcase name))) + (intern name :dom)) + +(defun child-elements (element) + (map-child-elements 'list #'identity element)) + +(defun parse-java-literal (str) + (when (stringp str) + (setf str (runes:string-rod str))) + (cond + ((zerop (length str)) nil) + ((runes:rod= str #"true") + t) + ((runes:rod= str #"false") + nil) + ((digit-char-p (runes:rune-char (elt str 0))) + (parse-integer (runes:rod-string str))) + ((runes:rune= (elt str 0) #.(runes:char-rune #\")) + (let ((v (make-array 1 :fill-pointer 0 :adjustable t))) + (for* ((i = 1 :then (1+ i)) + (c = (elt str i)) + :until (runes:rune= c #.(runes:char-rune #\"))) + (if (runes:rune= c #.(runes:char-rune #\\)) + (let ((frob + (progn + (incf i) + (elt str i)))) + (ecase frob + ;; ... + (#/n (vector-push-extend #/newline v (length v))) + ((#/\\ #/\") (vector-push-extend #/\\ v (length v))))) + (vector-push-extend c v (length v)))) + (make-array (length v) :element-type 'runes:rune :initial-contents v))) + (t + (%intern str)))) + +(defun maybe-setf (place form) + (if place + `(setf ,place ,form) + form)) + +(defun nullify (str) + (if (zerop (length str)) nil str)) + + +;;;; dom1-interfaces.xml auslesen + +(defparameter *methods* '()) +(defparameter *fields* '()) + +(declaim (special *directory*)) +(declaim (special *files-directory*)) + +(defun read-members (&optional (directory *directory*)) + (let* ((pathname (merge-pathnames "build/dom2-interfaces.xml" directory)) + (builder (rune-dom:make-dom-builder)) + (library (dom:document-element + (cxml:parse-file pathname builder :recode nil))) + (methods '()) + (fields '())) + (do-child-elements (interface library :name "interface") + (do-child-elements (method interface :name "method") + (let ((parameters (find-child-element "parameters" method))) + (push (cons (dom:get-attribute method "name") + (map-child-elements 'list + (rcurry #'dom:get-attribute "name") + parameters + :name "param")) + methods))) + (do-child-elements (attribute interface :name "attribute") + (push (dom:get-attribute attribute "name") fields))) + (values methods fields))) + + +;;;; Conditions uebersetzen + +(defun translate-condition (element) + (string-case (tag-name element) + ("equals" (translate-equals element)) + ("notEquals" (translate-not-equals element)) + ("contentType" (translate-content-type element)) + ("implementationAttribute" (assert-have-implementation-attribute element)) + ("isNull" (translate-is-null element)) + ("not" (translate-is-null element)) + ("notNull" (translate-not-null element)) + ("or" (translate-or element)) + ("same" (translate-same element)) + ("less" (translate-less element)) + (t (error "unknown condition: ~A" element)))) + +(defun equalsp (a b test) + (when (dom:named-node-map-p a) + (setf a (dom:items a))) + (when (dom:named-node-map-p b) + (setf b (dom:items b))) + (if (and (typep a 'sequence) (typep b 'sequence)) + (null (set-exclusive-or (coerce a 'list) (coerce b 'list) :test test)) + (funcall test a b))) + +(defun %equal (a b) + (or (equal a b) (and (runes::rodp a) (runes::rodp b) (runes:rod= a b)))) + +(defun %equalp (a b) + (or (equalp a b) (and (runes::rodp a) (runes::rodp b) (runes:rod-equal a b)))) + +(defun translate-equals (element) + (with-attributes (|actual| |expected| |ignoreCase|) element + `(equalsp ,(%intern |actual|) + ,(parse-java-literal |expected|) + ',(if (parse-java-literal |ignoreCase|) '%equal '%equal)))) + +(defun translate-not-equals (element) + `(not ,(translate-equals element))) + +(defun translate-same (element) + (with-attributes (|actual| |expected|) element + `(eql ,(%intern |actual|) ,(parse-java-literal |expected|)))) + +(defun translate-less (element) + (with-attributes (|actual| |expected|) element + `(< ,(%intern |actual|) ,(parse-java-literal |expected|)))) + +(defun translate-or (element) + `(or ,@(map-child-elements 'list #'translate-condition element))) + +(defun translate-instance-of (element) + (with-attributes (|obj| |type|) element + `(eq (dom:node-type ,(%intern |obj|)) + ',(string-case (runes:rod-string |type|) + ("Document" :document) + ("DocumentFragment" :document-fragment) + ("Text" :text) + ("Comment" :comment) + ("CDATASection" :cdata-section) + ("Attr" :attribute) + ("Element" :element) + ("DocumentType" :document-type) + ("Notation" :notation) + ("Entity" :entity) + ("EntityReference" :entity-reference) + ("ProcessingInstruction" :processing-instruction) + (t (error "unknown interface: ~A" |type|)))))) + +(defun translate-is-null (element) + (with-attributes (|obj|) element + `(null ,(%intern |obj|)))) + +(defun translate-not-null (element) + (with-attributes (|obj|) element + (%intern |obj|))) + +(defun translate-content-type (element) ;XXX verstehe ich nicht + (with-attributes (|type|) element + `(equal ,|type| "text/xml"))) + +(defun translate-uri-equals (element) + (with-attributes + (|actual| + |scheme| |path| |host| |file| |name| |query| |fragment| |isAbsolute|) + element + |isAbsolute| + `(let ((uri (net.uri:parse-uri (runes:rod-string ,(%intern |actual|))))) + (flet ((uri-directory (path) + (namestring + (make-pathname :directory (pathname-directory path)))) + (uri-file (path) + (namestring (make-pathname :name (pathname-name path) + :type (pathname-type path)))) + (uri-name (path) + (pathname-name path)) + (maybe-equal (expected actual) + (if expected + (%equal (runes::rod expected) (runes::rod actual)) + t))) + (and (maybe-equal ,(parse-java-literal |scheme|) + (net.uri:uri-scheme uri)) + (maybe-equal ,(parse-java-literal |host|) + (net.uri:uri-host uri)) + (maybe-equal ,(parse-java-literal |path|) + (uri-directory (net.uri:uri-path uri))) + (maybe-equal ,(parse-java-literal |file|) + (uri-file (net.uri:uri-path uri))) + (maybe-equal ,(parse-java-literal |name|) + (uri-name (net.uri:uri-path uri))) + (maybe-equal ,(parse-java-literal |query|) + (net.uri:uri-query uri)) + (maybe-equal ,(parse-java-literal |fragment|) + (net.uri:uri-fragment uri))))))) + + +;;;; Statements uebersetzen + +(defun translate-statement (element) + (string-case (tag-name element) + ("append" (translate-append element)) + ("assertDOMException" (translate-assert-domexception element)) + ("assertEquals" (translate-assert-equals element)) + ("assertNotNull" (translate-assert-not-null element)) + ("assertInstanceOf" (translate-assert-instance-of element)) + ("assertNull" (translate-assert-null element)) + ("assertSame" (translate-assert-same element)) + ("assertSize" (translate-assert-size element)) + ("assertTrue" (translate-assert-true element)) + ("assertFalse" (translate-assert-false element)) + ("assertURIEquals" (translate-assert-uri-equals element)) + ("assign" (translate-assign element)) + ("for-each" (translate-for-each element)) + ("fail" (translate-fail element)) + ("hasFeature" (translate-has-feature element)) + ("if" (translate-if element)) + ("implementation" (translate-implementation element)) + ("increment" (translate-unary-assignment '+ element)) + ("decrement" (translate-unary-assignment '- element)) + ("length" (translate-length element)) + ("load" (translate-load element)) + ("nodeType" (translate-node-type element)) + ("plus" (translate-binary-assignment '+ element)) + ("try" (translate-try element)) + ("while" (translate-while element)) + (t (translate-member element)))) + +(defun translate-binary-assignment (fn element) + (with-attributes (|var| |op1| |op2|) element + (maybe-setf (%intern |var|) + `(,fn ,(parse-java-literal |op1|) + ,(parse-java-literal |op2|))))) + +(defun translate-assign (element) + (with-attributes (|var| |value|) element + (maybe-setf (%intern |var|) (parse-java-literal |value|)))) + +(defun translate-unary-assignment (fn element) + (with-attributes (|var| |value|) element + (maybe-setf (%intern |var|) + `(,fn ,(%intern |var|) ,(parse-java-literal |value|))))) + +(defun translate-load (load) + (with-attributes (|var| |href| |willBeModified|) load + (maybe-setf (%intern |var|) + `(load-file ,|href| ,(parse-java-literal |willBeModified|))))) + +(defun translate-implementation (elt) + (with-attributes (|var|) elt + (maybe-setf (%intern |var|) `'rune-dom:implementation))) + +(defun translate-length (load) + ;; XXX Soweit ich sehe unterscheiden die Tests nicht zwischen + ;; der Laenge von DOMString und der length()-Methode der uebrigen + ;; Interfaces. Also unterscheiden wir das erstmal manuell. + (with-attributes (|var| |obj|) load + (let ((obj (%intern |obj|))) + (maybe-setf (%intern |var|) + `(if (typep ,obj 'sequence) + (length ,obj) + (dom:length ,obj)))))) + +(defun translate-call (call method) + (let ((name (car method)) + (args (mapcar (lambda (name) + (parse-java-literal (dom:get-attribute call name))) + (cdr method)))) + (with-attributes (|var| |obj|) call + (maybe-setf (%intern |var|) + `(,(intern-dom name) ,(%intern |obj|) ,@args))))) + +(defun translate-get (call name) + (with-attributes (|var| |value| |obj|) call + (cond + ((nullify |var|) ;get + (maybe-setf (%intern |var|) `(,(intern-dom name) ,(%intern |obj|)))) + ((nullify |value|) ;set + `(setf (,(intern-dom name) ,(%intern |obj|)) + ,(parse-java-literal |value|))) + (t + (error "oops"))))) + +(defun translate-has-feature (element) + (with-attributes (|obj| |var| |feature| |version|) element + (if (nullify |obj|) + (translate-member element) + (maybe-setf (%intern |var|) + `(dom:has-feature 'rune-dom:implementation + ,(parse-java-literal |feature|) + ,(parse-java-literal |version|)))))) + +(defun translate-fail (element) + (declare (ignore element)) + `(error "failed")) + +(defun translate-node-type (element) + ;; XXX Das muessten eigentlich ints sein, sind aber Keywords in CXML. + (with-attributes (|var| |obj|) element + (maybe-setf (%intern |var|) + `(ecase (dom:node-type ,(%intern |obj|)) + (:element 1) + (:attribute 2) + (:text 3) + (:cdata-section 4) + (:entity-reference 5) + (:entity 6) + (:processing-instruction 7) + (:comment 8) + (:document 9) + (:document-type 10) + (:document-fragment 11) + (:notation 12))))) + +(defun translate-member (element) + (let* ((name (dom:tag-name element)) + (method (find name *methods* :key #'car :test #'runes:rod=)) + (field (find name *fields* :test #'runes:rod=))) + (cond + (method (translate-call element method)) + (field (translate-get element field)) + (t (error "unknown element ~A" element))))) + +(defun translate-assert-equals (element) + `(assert ,(translate-equals element))) + +(defun translate-assert-same (element) + `(assert ,(translate-same element))) + +(defun translate-assert-null (element) + (with-attributes (|actual|) element + `(assert (null ,(%intern |actual|))))) + +(defun translate-assert-not-null (element) + (with-attributes (|actual|) element + `(assert ,(%intern |actual|)))) + +(defun translate-assert-size (element) + (with-attributes (|collection| |size|) element + `(let ((collection ,(%intern |collection|))) + (when (dom:named-node-map-p collection) + (setf collection (dom:items collection))) + (assert (eql (length collection) ,(parse-java-literal |size|)))))) + +(defun translate-assert-instance-of (element) + `(assert ,(translate-instance-of element))) + +(defun translate-if (element) + (destructuring-bind (condition &rest rest) + (child-elements element) + (let (then else) + (dolist (r rest) + (when (equal (tag-name r) "else") + (setf else (child-elements r)) + (return)) + (push r then)) + `(cond + (,(translate-condition condition) + ,@(mapcar #'translate-statement (reverse then))) + (t + ,@(mapcar #'translate-statement else)))))) + +(defun translate-while (element) + (destructuring-bind (condition &rest body) + (child-elements element) + `(loop + while ,(translate-condition condition) + do (progn ,@(mapcar #'translate-statement body))))) + +(defun translate-assert-domexception (element) + (do-child-elements (c element) + (unless (equal (tag-name c) "metadata") + (return + `(block assert-domexception + (handler-bind + ((rune-dom::dom-exception + (lambda (c) + (when (eq (rune-dom::dom-exception-key c) + ,(intern (tag-name c) :keyword)) + (return-from assert-domexception))))) + ,@(translate-body c) + (error "expected exception ~A" ,(tag-name c)))))))) + +(defun translate-catch (catch return) + `(lambda (c) + ,@(map-child-elements + 'list + (lambda (exception) + `(when (eq (rune-dom::dom-exception-key c) + ,(intern (runes:rod-string (dom:get-attribute exception "code")) + :keyword)) + ,@(translate-body exception) + ,return)) + catch))) + +(defun translate-try (element) + `(block try + (handler-bind + ((rune-dom::dom-exception + ,(translate-catch + (do-child-elements (c element :name "catch") (return c)) + '(return-from try)))) + ,@(map-child-elements 'list + (lambda (c) + (if (equal (tag-name c) "catch") + nil + (translate-statement c))) + element)))) + +(defun translate-append (element) + (with-attributes (|collection| |item|) element + (let ((c (%intern |collection|)) + (i (%intern |item|))) + (maybe-setf c `(append ,c (list ,i)))))) + +(defun translate-assert-true (element) + (with-attributes (|actual|) element + `(assert ,(if (nullify |actual|) + (%intern |actual|) + (translate-condition + (do-child-elements (c element) (return c))))))) + +(defun translate-assert-false (element) + (with-attributes (|actual|) element + `(assert (not ,(%intern |actual|))))) + +(defun translate-assert-uri-equals (element) + `(assert ,(translate-uri-equals element))) + + +;;;; Tests uebersetzen + +(defun translate-body (element) + (map-child-elements 'list #'translate-statement element)) + +(defun translate-for-each (element) + (with-attributes (|collection| |member|) element + `(let ((collection ,(%intern |collection|))) + (when (dom:named-node-map-p collection) + (setf collection (dom:items collection))) + (map nil (lambda (,(%intern |member|)) ,@(translate-body element)) + collection)))) + +(defun assert-have-implementation-attribute (element) + (let ((attribute (runes:rod-string (dom:get-attribute element "name")))) + (string-case attribute + ;; fixme: expandEntityReferences sollten wir auch mal anschalten, wo + ;; wir uns schon die muehe machen... + ("validating" + (setf cxml::*validate* t)) + ("namespaceAware" + ;; ??? dom 2 ohne namespace-support gibt's doch gar nicht, + ;; ausser vielleicht in html-only implementationen, und dann sollen + ;; sie halt auf hasFeature "XML" testen. + ) + (t + (format t "~&implementationAttribute ~A not supported, skipping test~%" + attribute) + (throw 'give-up nil))))) + +(defun slurp-test (pathname) + (unless *fields* + (multiple-value-setq (*methods* *fields*) (read-members))) + (catch 'give-up + (let* ((builder (rune-dom:make-dom-builder)) + (cxml::*validate* nil) ;dom1.dtd is buggy + (test (dom:document-element + (cxml:parse-file pathname builder :recode nil))) + title + (bindings '()) + (code '())) + (declare (ignorable title)) + (do-child-elements (e test) + (string-case (tag-name e) + ("metadata" + (let ((title-element (find-child-element "title" e))) + (setf title (dom:data (dom:first-child title-element))))) + ("var" + (push (list (%intern (dom:get-attribute e "name")) + (string-case (runes:rod-string + (dom:get-attribute e "type")) + (("byte" "short" "int" "long") 0) + (t nil))) + bindings) + (let ((value (dom:get-attribute e "value"))) + (when value + (push `(setf ,(%intern (dom:get-attribute e "name")) + ,(parse-java-literal value)) + code))) + (do-child-elements (member e :name "member") e + (push `(setf ,(%intern (dom:get-attribute e "name")) + (append ,(%intern (dom:get-attribute e "name")) + (list + ,(parse-java-literal + (dom:data + (dom:item + (dom:child-nodes member) + 0)))))) + code))) + ("implementationAttribute" + (assert-have-implementation-attribute e)) + (t + (push (translate-statement e) code)))) + `(lambda () + (let ((*files-directory* ,*files-directory*) ;fuer copy&paste: + ,@bindings) + (declare (ignorable ,@(mapcar #'car bindings))) + ,@(reverse code)))))) + +(defun load-file (name &optional will-be-modified-p) + (declare (ignore will-be-modified-p)) + (setf name (runes:rod-string name)) + (cxml:parse-file + (make-pathname :name name :type "xml" :defaults *files-directory*) + (rune-dom:make-dom-builder) + :recode nil)) + +(defparameter *bad-tests* + '("hc_elementnormalize2.xml" + "hc_nodereplacechildnewchildexists.xml" + "characterdatadeletedatanomodificationallowederr.xml")) + +(defun dribble-tests (directory) + (let ((base (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname))) + (with-open-file (*standard-output* + (merge-pathnames "DOMTEST" base) + :direction :output + :if-exists :supersede) + (run-all-tests directory)))) + +(defun run-all-tests (*directory* &optional verbose) + (let* ((cxml::*redefinition-warning* nil) + (n 0) + (i 0) + (ntried 0) + (nfailed 0)) + (flet ((parse (test-directory) + (let* ((all-tests (merge-pathnames "alltests.xml" test-directory)) + (builder (rune-dom:make-dom-builder)) + (suite (dom:document-element + (cxml:parse-file all-tests builder :recode nil))) + (*files-directory* + (merge-pathnames "files/" test-directory))) + (do-child-elements (member suite) + (unless + (or (equal (dom:tag-name member) "metadata") + (member (runes:rod-string + (dom:get-attribute member "href")) + *bad-tests* + :test 'equal)) + (incf n))) + suite)) + (run (test-directory suite) + (print test-directory) + (let ((*files-directory* + (merge-pathnames "files/" test-directory))) + (do-child-elements (member suite) + (let ((href (runes:rod-string + (dom:get-attribute member "href")))) + (unless (or (runes:rod= (dom:tag-name member) #"metadata") + (member href *bad-tests* :test 'equal)) + (format t "~&~D/~D ~A~%" i n href) + (let ((lisp (slurp-test + (merge-pathnames href test-directory)))) + (when verbose + (print lisp)) + (when lisp + (incf ntried) + (with-simple-restart (skip-test "Skip this test") + (handler-case + (let ((cxml::*validate* nil)) + (funcall (compile nil lisp))) + (serious-condition (c) + (incf nfailed) + (format t "~&TEST FAILED: ~A~&" c)))))) + (incf i))))))) + (let* ((d1 (merge-pathnames "tests/level1/core/" *directory*)) + (d2 (merge-pathnames "tests/level2/core/" *directory*)) + (suite1 (parse d1)) + (suite2 (parse d2))) + (run d1 suite1) + (run d2 suite2))) + (format t "~&~D/~D tests failed; ~D test~:P were skipped" + nfailed ntried (- n ntried)))) + +(defun run-test (*directory* level href) + (let* ((test-directory + (ecase level + (1 (merge-pathnames "tests/level1/core/" *directory*)) + (2 (merge-pathnames "tests/level2/core/" *directory*)))) + (*files-directory* (merge-pathnames "files/" test-directory)) + (lisp (slurp-test (merge-pathnames href test-directory))) + (cxml::*validate* nil)) + (print lisp) + (fresh-line) + (when lisp + (funcall (compile nil lisp))))) + +#+(or) +(domtest::run-all-tests "/home/david/2001/DOM-Test-Suite/") + +#+(or) +(domtest::run-test "/home/david/2001/DOM-Test-Suite/" + 1 + "attrcreatedocumentfragment.xml") Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/misc.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/misc.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/misc.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,29 @@ +;;; +;;; When I'll grow up, I'll be a complete test suite. + +(deftest utf-8 + (flet ((doit (from below) + (loop for code from from below below do + (when (and (code-char code) + (not (eql code #xfffe)) + (not (eql code #xffff))) + (let* ((a (if (< code #x10000) + (format nil "abc~C" (code-char code)) + (let* ((x (- code #x10000)) + (lo (ldb (byte 10 0) x)) + (hi (ldb (byte 10 10) x))) + (format nil "abc~C~C" + (code-char (logior #xD800 hi)) + (code-char + (logior #xDC00 lo)))))) + (b (cxml:utf8-string-to-rod + (cxml:rod-to-utf8-string + a)))) + (unless (string= a b) + (format t "FAIL: ~S ~A ~A~%" + (code-char code) + (map 'vector #'char-code a) + (map 'vector #'char-code b)))))))) + (doit 32 #xD800) + (doit #x10000 char-code-limit) + (values))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/utf8domtest.diff =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/utf8domtest.diff 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/utf8domtest.diff 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,102 @@ +Index: test/domtest.lisp +=================================================================== +RCS file: /project/cxml/cvsroot/cxml/test/domtest.lisp,v +retrieving revision 1.13 +diff -u -r1.13 domtest.lisp +--- test/domtest.lisp 27 Dec 2005 00:21:37 -0000 1.13 ++++ test/domtest.lisp 27 Dec 2005 00:46:00 -0000 +@@ -137,21 +137,22 @@ + ((digit-char-p (runes:rune-char (elt str 0))) + (parse-integer (runes:rod-string str))) + ((runes:rune= (elt str 0) #.(runes:char-rune #\")) +- (let ((v (make-array 1 :fill-pointer 0 :adjustable t))) +- (for* ((i = 1 :then (1+ i)) +- (c = (elt str i)) +- :until (runes:rune= c #.(runes:char-rune #\"))) +- (if (runes:rune= c #.(runes:char-rune #\\)) +- (let ((frob +- (progn +- (incf i) +- (elt str i)))) +- (ecase frob +- ;; ... +- (#/n (vector-push-extend #/newline v (length v))) +- ((#/\\ #/\") (vector-push-extend #/\\ v (length v))))) +- (vector-push-extend c v (length v)))) +- (coerce v 'runes::simple-rod))) ++ (utf8-dom::%rod ++ (let ((v (make-array 1 :fill-pointer 0 :adjustable t))) ++ (for* ((i = 1 :then (1+ i)) ++ (c = (elt str i)) ++ :until (runes:rune= c #.(runes:char-rune #\"))) ++ (if (runes:rune= c #.(runes:char-rune #\\)) ++ (let ((frob ++ (progn ++ (incf i) ++ (elt str i)))) ++ (ecase frob ++ ;; ... ++ (#/n (vector-push-extend #/newline v (length v))) ++ ((#/\\ #/\") (vector-push-extend #/\\ v (length v))))) ++ (vector-push-extend c v (length v)))) ++ (coerce v 'runes::simple-rod)))) + (t + (%intern str)))) + +@@ -368,7 +369,7 @@ + + (defun translate-implementation (elt) + (with-attributes (|var|) elt +- (maybe-setf (%intern |var|) `'rune-dom:implementation))) ++ (maybe-setf (%intern |var|) `'utf8-dom:implementation))) + + (defun translate-length (load) + ;; XXX Soweit ich sehe unterscheiden die Tests nicht zwischen +@@ -406,7 +407,7 @@ + (if (nullify |obj|) + (translate-member element) + (maybe-setf (%intern |var|) +- `(dom:has-feature 'rune-dom:implementation ++ `(dom:has-feature 'utf8-dom:implementation + ,(parse-java-literal |feature|) + ,(parse-java-literal |version|)))))) + +@@ -493,9 +494,9 @@ + (return + `(block assert-domexception + (handler-bind +- ((rune-dom::dom-exception ++ ((utf8-dom::dom-exception + (lambda (c) +- (when (eq (rune-dom::dom-exception-key c) ++ (when (eq (utf8-dom::dom-exception-key c) + ,(intern (tag-name c) :keyword)) + (return-from assert-domexception))))) + ,@(translate-body c) +@@ -506,7 +507,7 @@ + ,@(map-child-elements + 'list + (lambda (exception) +- `(when (eq (rune-dom::dom-exception-key c) ++ `(when (eq (utf8-dom::dom-exception-key c) + ,(intern (runes:rod-string (dom:get-attribute exception "code")) + :keyword)) + ,@(translate-body exception) +@@ -516,7 +517,7 @@ + (defun translate-try (element) + `(block try + (handler-bind +- ((rune-dom::dom-exception ++ ((utf8-dom::dom-exception + ,(translate-catch + (do-child-elements (c element :name "catch") (return c)) + '(return-from try)))) +@@ -631,7 +632,7 @@ + (setf name (runes:rod-string name)) + (cxml:parse-file + (make-pathname :name name :type "xml" :defaults *files-directory*) +- (rune-dom:make-dom-builder))) ++ (cxml:make-recoder (utf8-dom:make-dom-builder) 'cxml:rod-to-utf8-string))) + + (defparameter *bad-tests* + '("hc_elementnormalize2.xml" Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/xmlconf-base.diff =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/xmlconf-base.diff 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/xmlconf-base.diff 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,53 @@ +A recent check-in to the XML-Test-Suite's metadata has broken my parser for +xmlconf.xml. Apply this patch to revert it. + +Index: oasis/oasis.xml +=================================================================== +RCS file: /sources/public/2001/XML-Test-Suite/xmlconf/oasis/oasis.xml,v +retrieving revision 1.5 +retrieving revision 1.6 +diff -u -r1.5 -r1.6 +--- oasis/oasis.xml 16 May 2002 14:46:32 -0000 1.5 ++++ oasis/oasis.xml 4 Mar 2004 18:23:37 -0000 1.6 +@@ -1,6 +1,6 @@ + <?xml version='1.0' encoding='UTF-8'?> + +-<TESTCASES PROFILE='OASIS/NIST TESTS, 1-Nov-1998' xml:base="oasis/"> ++<TESTCASES PROFILE='OASIS/NIST TESTS, 1-Nov-1998'> + + <TEST TYPE='valid' SECTIONS='2.2 [1]' + ID='o-p01pass2' URI='p01pass2.xml'> +Index: xmltest/xmltest.xml +=================================================================== +RCS file: /sources/public/2001/XML-Test-Suite/xmlconf/xmltest/xmltest.xml,v +retrieving revision 1.9 +retrieving revision 1.10 +diff -u -r1.9 -r1.10 +--- xmltest/xmltest.xml 21 May 2002 19:05:57 -0000 1.9 ++++ xmltest/xmltest.xml 4 Mar 2004 18:25:11 -0000 1.10 +@@ -5,7 +5,7 @@ + All Rights Reserved. + --> + +-<TESTCASES PROFILE="James Clark XMLTEST cases, 18-Nov-1998" xml:base="xmltest/"> ++<TESTCASES PROFILE="James Clark XMLTEST cases, 18-Nov-1998"> + +  + <TEST TYPE="not-wf" ENTITIES="none" ID="not-wf-sa-001" +Index: japanese/japanese.xml +=================================================================== +RCS file: /sources/public/2001/XML-Test-Suite/xmlconf/japanese/japanese.xml,v +retrieving revision 1.4 +retrieving revision 1.5 +diff -u -r1.4 -r1.5 +--- japanese/japanese.xml 26 Mar 2002 14:43:54 -0000 1.4 ++++ japanese/japanese.xml 4 Mar 2004 18:18:39 -0000 1.5 +@@ -5,7 +5,7 @@ + All Rights Reserved. + --> + +-<TESTCASES PROFILE="Fuji Xerox Japanese Text Tests" xml:base="japanese/"> ++<TESTCASES PROFILE="Fuji Xerox Japanese Text Tests"> + + <TEST TYPE="error" SECTIONS="4.3.3 [4,84]" + ID="pr-xml-euc-jp" ENTITIES="parameter" URI="pr-xml-euc-jp.xml"> Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/xmlconf.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/xmlconf.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/test/xmlconf.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,232 @@ +(defpackage xmlconf + (:use :cl :runes) + (:export #:run-all-tests)) +(in-package :xmlconf) + +(defun get-attribute (element name) + (rod-string (dom:get-attribute element name))) + +(defparameter *bad-tests* + '(;; TS14 + ;; http://lists.w3.org/Archives/Public/public-xml-testsuite/2002Mar/0001.html + "ibm-valid-P28-ibm28v02.xml" + "ibm-valid-P29-ibm29v01.xml" + "ibm-valid-P29-ibm29v02.xml")) + +(defun test-class (test) + (cond + ((not (and (let ((version (get-attribute test "RECOMMENDATION"))) + (cond + ((or (equal version "") ;XXX + (equal version "XML1.0") + (equal version "NS1.0")) + (cond + ((equal (get-attribute test "NAMESPACE") "no") + (format t "~A: test applies to parsers without namespace support, skipping~%" + (get-attribute test "URI")) + nil) + (t + t))) + ((equal version "XML1.1") + ;; not supported + nil) + (t + (warn "unrecognized RECOMMENDATION value: ~S" version) + nil))) + (not (member (get-attribute test "ID") *bad-tests* :test 'equal)))) + nil) + ((equal (get-attribute test "TYPE") "valid") :valid) + ((equal (get-attribute test "TYPE") "invalid") :invalid) + ((equal (get-attribute test "TYPE") "not-wf") :not-wf) + (t nil))) + +(defun test-pathnames (directory test) + (let* ((sub-directory + (loop + for parent = test then (dom:parent-node parent) + for base = (get-attribute parent "xml:base") + until (plusp (length base)) + finally (return (merge-pathnames base directory)))) + (uri (get-attribute test "URI")) + (output (get-attribute test "OUTPUT"))) + (values (merge-pathnames uri sub-directory) + (when (plusp (length output)) + (merge-pathnames output sub-directory))))) + +(defmethod serialize-document ((document t)) + (dom:map-document (cxml:make-octet-vector-sink :canonical 2) + document + :include-doctype :canonical-notations + :include-default-values t)) + +(defun file-contents (pathname) + (with-open-file (s pathname :element-type '(unsigned-byte 8)) + (let ((result + (make-array (file-length s) :element-type '(unsigned-byte 8)))) + (read-sequence result s ) + result))) + +(defun dribble-tests (parser-fn directory) + (let ((base (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname))) + (with-open-file (*standard-output* + (merge-pathnames "XMLCONF" base) + :direction :output + :external-format :iso-8859-1 + :if-exists :supersede) + (run-all-tests parser-fn directory)))) + +(defvar *parser-fn* 'sax-test) + +(defun sax-test (filename handler &rest args) + (apply #'cxml:parse-file filename handler :recode nil args)) + +(defun klacks-test (filename handler &rest args) + (klacks:with-open-source + (s (apply #'cxml:make-source (pathname filename) args)) + (klacks:serialize-source s handler))) + +(defun run-all-tests (parser-fn directory) + (let* ((*parser-fn* parser-fn) + (pathname (merge-pathnames "xmlconf.xml" directory)) + (builder (rune-dom:make-dom-builder)) + (xmlconf (cxml:parse-file pathname builder :recode nil)) + (ntried 0) + (nfailed 0) + (nskipped 0) + ;; XXX someone found it funny to include invalid URIs in the + ;; test suite. And no, in "invalid" not "not-wf". + (puri:*strict-parse* nil)) + (dom:do-node-list (test (dom:get-elements-by-tag-name xmlconf "TEST")) + (let ((description + (apply #'concatenate + 'string + (map 'list + (lambda (child) + (if (dom:text-node-p child) + (rod-string (dom:data child)) + "")) + (dom:child-nodes test)))) + (class (test-class test))) + (cond + (class + (incf ntried) + (multiple-value-bind (pathname output) + (test-pathnames directory test) + (princ (enough-namestring pathname directory)) + (unless (probe-file pathname) + (error "file not found: ~A" pathname)) + (with-simple-restart (skip-test "Skip this test") + (unless (run-test class pathname output description) + (incf nfailed)) + (fresh-line)))) + (t + (incf nskipped))))) + (format t "~&~D/~D tests failed; ~D test~:P were skipped" + nfailed ntried nskipped))) + +(defmethod run-test :around (class pathname output description &rest args) + (declare (ignore class pathname output args)) + (handler-case + (call-next-method) + (serious-condition (c) + (format t " FAILED:~% ~A~%[~A]~%" c description) + nil))) + +(defmethod run-test ((class null) pathname output description &rest args) + (declare (ignore description)) + (let ((document (apply *parser-fn* + pathname + (rune-dom:make-dom-builder) + args))) + (cond + ((null output) + (format t " input")) + ((equalp (file-contents output) (serialize-document document)) + (format t " input/output")) + (t + (let ((error-output (make-pathname :type "error" :defaults output))) + (with-open-file (s error-output + :element-type '(unsigned-byte 8) + :direction :output + :if-exists :supersede) + (write-sequence (serialize-document document) s)) + (error "well-formed, but output ~S not the expected ~S~%" + error-output output)))) + t)) + +(defmethod run-test + ((class (eql :valid)) pathname output description &rest args) + (assert (null args)) + (and (progn + (format t " [not validating:]") + (run-test nil pathname output description :validate nil)) + (progn + (format t " [validating:]") + (run-test nil pathname output description :validate t)))) + +(defmethod run-test + ((class (eql :invalid)) pathname output description &rest args) + (assert (null args)) + (and (progn + (format t " [not validating:]") + (run-test nil pathname output description :validate nil)) + (handler-case + (progn + (format t " [validating:]") + (funcall *parser-fn* + pathname + (rune-dom:make-dom-builder) + :validate t) + (error "validity error not detected") + nil) + (cxml:validity-error () + (format t " invalid") + t)))) + +(defmethod run-test + ((class (eql :not-wf)) pathname output description &rest args) + (assert (null args)) + (handler-case + (progn + (format t " [not validating:]") + (funcall *parser-fn* + pathname + (rune-dom:make-dom-builder) + :validate nil) + (error "well-formedness violation not detected") + nil) + #+fixme-stp-test + (error () + (format t " unexpected-error") + t) + (cxml:well-formedness-violation () + (format t " not-wf") + t)) + (handler-case + (progn + (format t " [validating:]") + (funcall *parser-fn* + pathname + (rune-dom:make-dom-builder) + :validate t) + (error "well-formedness violation not detected") + nil) + #+fixme-stp-test + (error () + (format t " unexpected-error") + t) + (cxml:well-formedness-violation () + (format t " not-wf") + t) + (cxml:validity-error () + ;; das erlauben wir mal auch, denn valide => wf + (format t " invalid") + t))) + +#+(or) +(xmlconf::run-all-tests 'xmlconf::sax-test + "/home/david/2001/XML-Test-Suite/xmlconf/") + +#+(or) +(xmlconf::run-all-tests 'xmlconf::klacks-test + "/home/david/2001/XML-Test-Suite/xmlconf/") Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Entries 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Entries 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,14 @@ +/catalog.lisp/1.5/Sun Mar 4 21:04:13 2007// +/package.lisp/1.19/Sat Jul 7 20:47:39 2007// +/recoder.lisp/1.5/Thu Dec 29 00:31:36 2005// +/sax-handler.lisp/1.8/Sun Jul 1 17:25:45 2007// +/sax-proxy.lisp/1.6/Sun May 20 09:38:35 2007// +/space-normalizer.lisp/1.2/Thu Dec 29 00:39:25 2005// +/split-sequence.lisp/1.1.1.1/Sun Mar 13 18:02:35 2005// +/unparse.lisp/1.20/Sun Aug 5 11:16:15 2007// +/util.lisp/1.2/Mon Nov 28 22:33:47 2005// +/xml-name-rune-p.lisp/1.8/Sun Sep 10 14:52:44 2006// +/xml-parse.lisp/1.72/Sun Aug 5 11:15:48 2007// +/xmlns-normalizer.lisp/1.4/Sat Jun 16 11:07:58 2007// +/xmls-compat.lisp/1.5/Sun Jul 1 17:26:04 2007// +D Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Entries.Log =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Entries.Log 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Entries.Log 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +A D/sax-tests//// Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Repository 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Repository 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +cxml/xml Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Root 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/CVS/Root 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +:ext:dlichteblau@common-lisp.net:/project/cxml/cvsroot Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/catalog.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/catalog.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/catalog.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,349 @@ +;;;; catalogs.lisp -- XML Catalogs -*- Mode: Lisp; readtable: runes -*- +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Developed 2004 for headcraft - http://headcraft.de/ +;;;; Copyright: David Lichteblau + +(in-package :cxml) + +;;; http://www.oasis-open.org/committees/entity/spec.html +;;; +;;; Bugs: +;;; - We validate using the Catalog DTD while parsing, which is too strict +;;; and will will fail to parse files using other parser's extensions. +;;; (Jedenfalls behauptet das die Spec.) +;;; A long-term solution might be an XML Schema validator. + +(defvar *prefer* :public) +(defvar *default-catalog* + '(;; libxml standard + "/etc/xml/catalog" + ;; FreeBSD + "/usr/local/share/xml/catalog.ports")) + +(defstruct (catalog (:constructor %make-catalog ())) + main-files + (dtd-cache (make-dtd-cache)) + (file-table (puri:make-uri-space))) + +(defstruct (entry-file (:conc-name "")) + (system-entries) ;extid 2 + (rewrite-system-entries) ; 3 + (delegate-system-entries) ; 4 + (public-entries) ; 5 + (delegate-public-entries) ; 6 + (uri-entries) ;uri 2 + (rewrite-uri-entries) ; 3 + (delegate-uri-entries) ; 4 + (next-catalog-entries) ; 5/7 + ) + +(defun starts-with-p (string prefix) + (let ((mismatch (mismatch string prefix))) + (or (null mismatch) (= mismatch (length prefix))))) + +(defun normalize-public (str) + (setf str (rod-to-utf8-string (rod str))) + (flet ((whitespacep (c) + (find c #.(map 'string #'code-char '(#x9 #xa #xd #x20))))) + (let ((start (position-if-not #'whitespacep str)) + (end (position-if-not #'whitespacep str :from-end t)) + (spacep nil)) + (with-output-to-string (out) + (when start + (loop for i from start to end do + (let ((c (char str i))) + (cond + ((whitespacep c) + (unless spacep + (setf spacep t) + (write-char #\space out))) + (t + (setf spacep nil) + (write-char c out)))))))))) + +(defun normalize-uri (str) + (when (typep str 'puri:uri) + (setf str (puri:render-uri str nil))) + (setf str (rod-to-utf8-string (rod str))) + (with-output-to-string (out) + (loop for ch across str do + (let ((c (char-code ch))) + (if (< c 15) + (write-string (string-upcase (format nil "%~2,'0X" c)) out) + (write-char ch out)))))) + +(defun unwrap-publicid (str) + (normalize-public + (with-output-to-string (out) + (let ((i (length "urn:publicid:")) + (n (length str))) + (while (< i n) + (let ((c (char str i))) + (case c + (#\+ (write-char #\space out)) + (#\: (write-string "//" out)) + (#\; (write-string "::" out)) + (#\% + (let ((code + (parse-integer str + :start (+ i 1) + :end (+ i 3) + :radix 16))) + (write-char (code-char code) out)) + (incf i 2)) + (t (write-char c out)))) + (incf i)))))) + +(defun match-exact (key table &optional check-prefer) + (dolist (pair table) + (destructuring-bind (from to &optional prefer) pair + (when (and (equal key from) (or (not check-prefer) (eq prefer :public))) + (return to))))) + +(defun match-prefix/rewrite (key table &optional check-prefer) + (let ((match nil) + (match-length -1)) + (dolist (pair table) + (destructuring-bind (from to &optional prefer) pair + (when (and (or (not check-prefer) (eq prefer :public)) + (starts-with-p key from) + (> (length from) match-length)) + (setf match-length (length from)) + (setf match to)))) + (if match + (concatenate 'string + match + (subseq key match-length)) + nil))) + +(defun match-prefix/sorted (key table &optional check-prefer) + (let ((result '())) + (dolist (pair table) + (destructuring-bind (from to &optional prefer) pair + (when (and (or (not check-prefer) (eq prefer :public)) + (starts-with-p key from)) + (push (cons (length from) to) result)))) + (mapcar #'cdr (sort result #'> :key #'car)))) + +(defun resolve-extid (public system catalog) + (when public (setf public (normalize-public public))) + (when system (setf system (normalize-uri system))) + (when (and system (starts-with-p system "urn:publicid:")) + (let ((new-public (unwrap-publicid system))) + (assert (or (null public) (equal public new-public))) + (setf public new-public + system nil))) + (let ((files (catalog-main-files catalog)) + (seen '())) + (while files + (let ((file (pop files)) + (delegates nil)) + (unless (typep file 'entry-file) + (setf file (find-catalog-file file catalog))) + (unless (or (null file) (member file seen)) + (push file seen) + (when system + (let ((result + (or (match-exact system (system-entries file)) + (match-prefix/rewrite + system + (rewrite-system-entries file))))) + (when result + (return result)) + (setf delegates + (match-prefix/sorted + system + (delegate-system-entries file))))) + (when (and public (not delegates)) + (let* ((check-prefer (and system t)) + (result + (match-exact public + (public-entries file) + check-prefer))) + (when result + (return result)) + (setf delegates + (match-prefix/sorted + public + (delegate-public-entries file) + check-prefer)))) + (if delegates + (setf files delegates) + (setf files (append (next-catalog-entries file) files)))))))) + +(defun resolve-uri (uri catalog) + (setf uri (normalize-uri uri)) + (when (starts-with-p uri "urn:publicid:") + (return-from resolve-uri + (resolve-extid (unwrap-publicid uri) nil catalog))) + (let ((files (catalog-main-files catalog)) + (seen '())) + (while files + (let ((file (pop files))) + (unless (typep file 'entry-file) + (setf file (find-catalog-file file catalog))) + (unless (or (null file) (member file seen)) + (push file seen) + (let ((result + (or (match-exact uri (uri-entries file)) + (match-prefix/rewrite uri (rewrite-uri-entries file))))) + (when result + (return result)) + (let* ((delegate-entries + (delegate-uri-entries file)) + (delegates + (match-prefix/sorted uri delegate-entries))) + (if delegates + (setf files delegates) + (setf files (append (next-catalog-entries file) files)))))))))) + +(defun find-catalog-file (uri catalog) + (setf uri (if (stringp uri) (safe-parse-uri uri) uri)) + (let* ((*dtd-cache* (catalog-dtd-cache catalog)) + (*cache-all-dtds* t) + (file (parse-catalog-file uri))) + (when file + (let ((interned (puri:intern-uri uri (catalog-file-table catalog)))) + (setf (getf (puri:uri-plist interned) 'catalog) file))) + file)) + +(defun make-catalog (&optional (uris *default-catalog*)) + (let ((result (%make-catalog))) + (setf (catalog-main-files result) + (loop + for uri in uris + for file = (find-catalog-file uri result) + when file collect file)) + result)) + +(defun parse-catalog-file (uri) + (handler-case + (parse-catalog-file/strict uri) + ((or file-error xml-parse-error) (c) + (warn "ignoring catalog error: ~A" c)))) + +(defparameter *catalog-dtd* + (let* ((cxml + (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname)) + (dtd (merge-pathnames "catalog.dtd" cxml))) + (with-open-file (s dtd :element-type '(unsigned-byte 8)) + (let ((bytes + (make-array (file-length s) :element-type '(unsigned-byte 8)))) + (read-sequence bytes s) + bytes)))) + +(defun parse-catalog-file/strict (uri) + (let* ((*catalog* nil) + (dtd-sysid + (puri:parse-uri "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd"))) + (flet ((entity-resolver (public system) + (declare (ignore public)) + (if (puri:uri= system dtd-sysid) + (make-octet-input-stream *catalog-dtd*) + nil))) + (with-open-stream (s (open (uri-to-pathname uri) + :element-type '(unsigned-byte 8) + :direction :input)) + (parse-stream s + (make-instance 'catalog-parser :uri uri) + :validate nil + :dtd (make-extid nil dtd-sysid) + :root #"catalog" + :entity-resolver #'entity-resolver))))) + +(defclass catalog-parser () + ((result :initform (make-entry-file) :accessor result) + (next :initform '() :accessor next) + (prefer-stack :initform (list *prefer*) :accessor prefer-stack) + (catalog-base-stack :accessor catalog-base-stack))) + +(defmethod initialize-instance :after + ((instance catalog-parser) &key uri) + (setf (catalog-base-stack instance) (list uri))) + +(defmethod prefer ((handler catalog-parser)) + (car (prefer-stack handler))) + +(defmethod base ((handler catalog-parser)) + (car (catalog-base-stack handler))) + +(defun get-attribute/lname (name attributes) + (let ((a (find name attributes + :key (lambda (a) + (or (sax:attribute-local-name a) + (sax:attribute-qname a))) + :test #'string=))) + (and a (sax:attribute-value a)))) + +(defmethod sax:start-element ((handler catalog-parser) uri lname qname attrs) + (declare (ignore uri)) + (setf lname (or lname qname)) + ;; we can dispatch on lnames only because we validate against the DTD, + ;; which disallows other namespaces. + ;; FIXME: we don't, because we can't. + (push (let ((new (get-attribute/lname "prefer" attrs))) + (cond + ((equal new "public") :public) + ((equal new "system") :system) + ((null new) (prefer handler)))) + (prefer-stack handler)) + (push (string-or (get-attribute/lname "base" attrs) (base handler)) + (catalog-base-stack handler)) + (flet ((geturi (lname) + (puri:merge-uris + (safe-parse-uri (get-attribute/lname lname attrs)) + (base handler)))) + (cond + ((string= lname "public") + (push (list (normalize-public (get-attribute/lname "publicId" attrs)) + (geturi "uri") + (prefer handler)) + (public-entries (result handler)))) + ((string= lname "system") + (push (list (normalize-uri (get-attribute/lname "systemId" attrs)) + (geturi "uri")) + (system-entries (result handler)))) + ((string= lname "uri") + (push (list (normalize-uri (get-attribute/lname "name" attrs)) + (geturi "uri")) + (uri-entries (result handler)))) + ((string= lname "rewriteSystem") + (push (list (normalize-uri + (get-attribute/lname "systemIdStartString" attrs)) + (get-attribute/lname "rewritePrefix" attrs)) + (rewrite-system-entries (result handler)))) + ((string= lname "rewriteURI") + (push (list (normalize-uri + (get-attribute/lname "uriStartString" attrs)) + (get-attribute/lname "rewritePrefix" attrs)) + (rewrite-uri-entries (result handler)))) + ((string= lname "delegatePublic") + (push (list (normalize-public + (get-attribute/lname "publicIdStartString" attrs)) + (geturi "catalog") + (prefer handler)) + (delegate-public-entries (result handler)))) + ((string= lname "delegateSystem") + (push (list (normalize-uri + (get-attribute/lname "systemIdStartString" attrs)) + (geturi "catalog")) + (delegate-system-entries (result handler)))) + ((string= lname "delegateURI") + (push (list (normalize-uri + (get-attribute/lname "uriStartString" attrs)) + (geturi "catalog")) + (delegate-uri-entries (result handler)))) + ((string= lname "nextCatalog") + (push (geturi "catalog") + (next-catalog-entries (result handler))))))) + +(defmethod sax:end-element ((handler catalog-parser) uri lname qname) + (declare (ignore uri lname qname)) + (pop (catalog-base-stack handler)) + (pop (prefer-stack handler))) + +(defmethod sax:end-document ((handler catalog-parser)) + (result handler)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/package.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/package.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,98 @@ +;;;; package.lisp -- Paketdefinition +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. + +(in-package :cl-user) + +(defpackage :cxml + (:use :cl :runes :runes-encoding #-scl :trivial-gray-streams) + (:export + ;; xstreams + #:make-xstream + #:make-rod-xstream + #:close-xstream + #:read-rune + #:peek-rune + #:unread-rune + #:fread-rune + #:fpeek-rune + #:xstream-position + #:xstream-line-number + #:xstream-column-number + #:xstream-plist + #:xstream-encoding + + ;; xstream controller protocol + #:read-octects + #:xstream/close + + #:attribute-namespace-uri + #:attribute-local-name + #:attribute-qname + #:attribute-value + + #:parse + #:parse-file + #:parse-stream + #:parse-rod + #:parse-octets + #:parse-empty-document + + #:make-octet-vector-sink + #:make-octet-stream-sink + #:make-rod-sink + #+rune-is-character #:make-string-sink + #+rune-is-character #:make-character-stream-sink + ;; See comment in runes/package.lisp + ;; #-rune-is-character + #:make-string-sink/utf8 + ;; #-rune-is-character + #:make-character-stream-sink/utf8 + + #:with-xml-output + #:with-namespace + #:with-element + #:with-element* + #:attribute + #:attribute* + #:unparse-attribute + #:cdata + #:text + #:doctype + + #:xml-parse-error + #:well-formedness-violation + #:validity-error + + #:parse-dtd-file + #:parse-dtd-stream + #:make-validator + + #:*cache-all-dtds* + #:*dtd-cache* + #:getdtd + #:remdtd + #:make-dtd-cache + #:clear-dtd-cache + #:make-extid + + #:*catalog* + #:*prefer* + #:make-catalog + #:resolve-uri + #:resolve-extid + + #:make-recoder + #:make-namespace-normalizer + #:make-whitespace-normalizer + #:rod-to-utf8-string + #:utf8-string-to-rod + + #:broadcast-handler + #:broadcast-handler-handlers + #:make-broadcast-handler + #:sax-proxy + #:proxy-chained-handler + + #:make-source)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/recoder.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/recoder.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/recoder.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,125 @@ +;;;; recoder.lisp -- SAX handler for string conversion +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Developed 2004 for headcraft - http://headcraft.de/ +;;;; Copyright: David Lichteblau + +(in-package :cxml) + +(defclass recoder () + ((recoder :initarg :recoder :accessor recoder) + (chained-handler :initarg :chained-handler :accessor chained-handler))) + +(defun make-recoder (chained-handler recoder-fn) + (make-instance 'recoder + :recoder recoder-fn + :chained-handler chained-handler)) + +(macrolet ((%string (rod) + `(let ((rod ,rod)) + (if (typep rod '(or rod string)) + (funcall (recoder handler) rod) + rod))) + (defwrapper (name (&rest args) &rest forms) + `(defmethod ,name ((handler recoder) ,@args) + (,name (chained-handler handler) ,@forms)))) + (defwrapper sax:start-document ()) + + (defwrapper sax:start-element + (namespace-uri local-name qname attributes) + (%string namespace-uri) + (%string local-name) + (%string qname) + (mapcar (lambda (attr) + (sax:make-attribute + :namespace-uri (%string (sax:attribute-namespace-uri attr)) + :local-name (%string (sax:attribute-local-name attr)) + :qname (%string (sax:attribute-qname attr)) + :value (%string (sax:attribute-value attr)) + :specified-p (sax:attribute-specified-p attr))) + attributes)) + + (defwrapper sax:start-prefix-mapping (prefix uri) + (%string prefix) + (%string uri)) + + (defwrapper sax:characters (data) + (%string data)) + + (defwrapper sax:processing-instruction (target data) + (%string target) + (%string data)) + + (defwrapper sax:end-prefix-mapping (prefix) + (%string prefix)) + + (defwrapper sax:end-element (namespace-uri local-name qname) + (%string namespace-uri) + (%string local-name) + (%string qname)) + + (defwrapper sax:end-document ()) + + (defwrapper sax:comment (data) + (%string data)) + + (defwrapper sax:start-cdata ()) + + (defwrapper sax:end-cdata ()) + + (defwrapper sax:start-dtd (name public-id system-id) + (%string name) + (%string public-id) + (%string system-id)) + + (defwrapper sax:start-internal-subset ()) + (defwrapper sax:end-internal-subset ()) + + (defwrapper sax:end-dtd ()) + + (defwrapper sax:unparsed-entity-declaration + (name public-id system-id notation-name) + (%string name) + (%string public-id) + (%string system-id) + (%string notation-name)) + + (defwrapper sax:external-entity-declaration + (kind name public-id system-id) + (%string kind) + (%string name) + (%string public-id) + (%string system-id)) + + (defwrapper sax:internal-entity-declaration + (kind name value) + kind + (%string name) + (%string value)) + + (defwrapper sax:notation-declaration + (name public-id system-id) + (%string name) + (%string public-id) + (%string system-id)) + + (defwrapper sax:element-declaration (name model) + (%string name) + model) + + (defwrapper sax:attribute-declaration + (element-name attribute-name type default) + (%string element-name) + (%string attribute-name) + (%string type) + (%string default)) + + (defwrapper sax:entity-resolver + (resolver) + resolver) + + (defwrapper sax::dtd + (dtd) + dtd)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-handler.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-handler.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-handler.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,422 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SAX; readtable: runes; Encoding: utf-8; -*- +;;; --------------------------------------------------------------------------- +;;; Title: A SAX2-like API for the xml parser +;;; Created: 2003-06-30 +;;; Author: Henrik Motakef <hmot(a)henrik-motakef.de> +;;; Author: David Lichteblau (DTD-related changes) +;;; License: BSD +;;; --------------------------------------------------------------------------- +;;; (c) copyright 2003 by Henrik Motakef +;;; (c) copyright 2004 knowledgeTools Int. GmbH + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions are +;;; met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution +;;; +;;; THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED +;;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;;; IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +;;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +;;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +;;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +;;; IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +;;; POSSIBILITY OF SUCH DAMAGE. + +;;; TODO/ Open Questions: + +;; o Should there be a predefined "handler" class, or even several +;; (like Java SAX' ContentHandler, DTDHandler, LexicalHandler etc? I +;; don't really see why. +;; o Missing stuff from Java SAX2: +;; * ignorable-whitespace +;; * skipped-entity +;; * The whole ErrorHandler class, this is better handled using +;; conditions (but isn't yet) +;; * The LexicalHandler (start-cdata etc) would be nice [-- partly done] + +(defpackage :sax + (:use :common-lisp) + (:export #:*namespace-processing* + #:*include-xmlns-attributes* + #:*use-xmlns-namespace* + + #:make-attribute + #:find-attribute + #:find-attribute-ns + #:attribute-namespace-uri + #:attribute-local-name + #:attribute-qname + #:attribute-value + #:attribute-specified-p + + #:start-document + #:start-prefix-mapping + #:start-element + #:characters + #:processing-instruction + #:end-element + #:end-prefix-mapping + #:end-document + #:comment + #:start-cdata + #:end-cdata + #:start-dtd + #:end-dtd + #:start-internal-subset + #:unparsed-internal-subset + #:end-internal-subset + #:unparsed-entity-declaration + #:external-entity-declaration + #:internal-entity-declaration + #:notation-declaration + #:element-declaration + #:attribute-declaration + #:entity-resolver + + #:sax-parser + #:sax-parser-mixin + #:register-sax-parser + #:line-number + #:column-number + #:system-id + #:xml-base)) + +(in-package :sax) + + +;;;; SAX-PARSER interface + +(defclass sax-parser () ()) + +(defclass sax-parser-mixin () + ((sax-parser :initform nil :reader sax-parser))) + +(defgeneric line-number (sax-parser) + (:documentation + "Return an approximation of the current line number, or NIL.") + (:method ((handler sax-parser-mixin)) + (if (sax-parser handler) + (line-number (sax-parser handler)) + nil))) + +(defgeneric column-number (sax-parser) + (:documentation + "Return an approximation of the current column number, or NIL.") + (:method ((handler sax-parser-mixin)) + (if (sax-parser handler) + (column-number (sax-parser handler)) + nil))) + +(defgeneric system-id (sax-parser) + (:documentation + "Return the URI of the document being parsed. This is either the + main document, or the entity's system ID while contents of a parsed + general external entity are being processed.") + (:method ((handler sax-parser-mixin)) + (if (sax-parser handler) + (system-id (sax-parser handler)) + nil))) + +(defgeneric xml-base (sax-parser) + (:documentation + "Return the [Base URI] of the current element. This URI can differ from + the value returned by SAX:SYSTEM-ID if xml:base attributes are present.") + (:method ((handler sax-parser-mixin)) + (if (sax-parser handler) + (xml-base (sax-parser handler)) + nil))) + + +;;;; Configuration variables + +;; The http://xml.org/sax/features/namespaces property +(defvar *namespace-processing* t + "If non-nil (the default), namespace processing is enabled. + +See also `start-element' and `end-element' for a detailed description +of the consequences of modifying this variable, and +`*include-xmlns-attributes*' and `*use-xmlns-namespace*' for further +related options.") + +;; The http://xml.org/sax/features/namespace-prefixes property. +(defvar *include-xmlns-attributes* t + "If non-nil, namespace declarations are reported as normal +attributes. + +This variable has no effect unless `*namespace-processing*' is +non-nil. + +See also `*use-xmlns-namespace*', and `start-element' for a detailed +description of the consequences of setting this variable.") + +(defvar *use-xmlns-namespace* t + "If this variable is nil (the default), attributes with a name like +'xmlns:x' are not considered to be in a namespace, following the +'Namespaces in XML' specification. + +If it is non-nil, such attributes are considered to be in a namespace +with the URI 'http://www.w3.org/2000/xmlns/', following an +incompatible change silently introduced in the errata to that spec, +and adopted by some W3C standards. + +For example, an attribute like xmlns:ex='http://example.com' would be +reported like this: + +*use-xmlns-namespace*: nil +namespace-uri: nil +local-name: nil +qname: #\"xmlns:ex\" + +*use-xmlns-namespace*: t +namespace-uri: #\"http://www.w3.org/2000/xmlns/\" +local-name: #\"ex\" +qname: #\"xmlns:ex\" + +Setting this variable has no effect unless both +`*namespace-processing*' and `*include-xmlns-attributes*' are non-nil.") + +(defstruct attribute + namespace-uri + local-name + qname + value + specified-p) + +(defun %rod= (x y) + ;; allow rods *and* strings *and* null + (cond + ((zerop (length x)) (zerop (length y))) + ((zerop (length y)) nil) + ((stringp x) (string= x y)) + (t (runes:rod= x y)))) + +(defun find-attribute (qname attrs) + (find qname attrs :key #'attribute-qname :test #'%rod=)) + +(defun find-attribute-ns (uri lname attrs) + (find-if (lambda (attr) + (and (%rod= uri (sax:attribute-namespace-uri attr)) + (%rod= lname (sax:attribute-local-name attr)))) + attrs)) + +(defgeneric start-document (handler) + (:documentation "Called at the beginning of the parsing process, +before any element, processing instruction or comment is reported. + +Handlers that need to maintain internal state may use this to perform +any neccessary initializations.") + (:method ((handler t)) nil)) + +(defgeneric start-element (handler namespace-uri local-name qname attributes) + (:documentation "Called to report the beginning of an element. + +There will always be a corresponding call to end-element, even in the +case of an empty element (i.e. <foo/>). + +If the value of *namespaces* is non-nil, namespace-uri, local-name and +qname are rods. If it is nil, namespace-uri and local-name are always +nil, and it is not an error if the qname is not a well-formed +qualified element name (for example, if it contains more than one +colon). + +The attributes parameter is a list (in arbitrary order) of instances +of the `attribute' structure class. The for their namespace-uri and +local-name properties, the same rules as for the element name +apply. Additionally, namespace-declaring attributes (those whose name +is \"xmlns\" or starts with \"xmlns:\") are only included if +*include-xmlns-attributes* is non-nil.") + (:method ((handler t) namespace-uri local-name qname attributes) + (declare (ignore namespace-uri local-name qname attributes)) + nil)) + +(defgeneric start-prefix-mapping (handler prefix uri) + (:documentation "Called when the scope of a new prefix -> namespace-uri mapping begins. + +This will always be called immediatly before the `start-element' event +for the element on which the namespaces are declared. + +Clients don't usually have to implement this except under special +circumstances, for example when they have to deal with qualified names +in textual content. The parser will handle namespaces of elements and +attributes on its own.") + (:method ((handler t) prefix uri) (declare (ignore prefix uri)) nil)) + +(defgeneric characters (handler data) + (:documentation "Called for textual element content. + +The data is passed as a rod, with all entity references resolved. +It is possible that the character content of an element is reported +via multiple subsequent calls to this generic function.") + (:method ((handler t) data) (declare (ignore data)) nil)) + +(defgeneric processing-instruction (handler target data) + (:documentation "Called when a processing instruction is read. + +Both target and data are rods.") + (:method ((handler t) target data) (declare (ignore target data)) nil)) + +(defgeneric end-prefix-mapping (handler prefix) + (:documentation "Called when a prefix -> namespace-uri mapping goes out of scope. + +This will always be called immediatly after the `end-element' event +for the element on which the namespace is declared. The order of the +end-prefix-mapping events is otherwise not guaranteed. + +Clients don't usually have to implement this except under special +circumstances, for example when they have to deal with qualified names +in textual content. The parser will handle namespaces of elements and +attributes on its own.") + (:method ((handler t) prefix) prefix nil)) + +(defgeneric end-element (handler namespace-uri local-name qname) + (:documentation "Called to report the end of an element. + +See the documentation for `start-element' for a description of the +parameters.") + (:method ((handler t) namespace-uri local-name qname) + (declare (ignore namespace-uri local-name qname)) + nil)) + +(defgeneric end-document (handler) + (:documentation "Called at the end of parsing a document. +This is always the last function called in the parsing process. + +In contrast to all of the other methods, the return value of this gf +is significant, it will be returned by the parse-file/stream/string function.") + (:method ((handler t)) nil)) + +;; LexicalHandler + +(defgeneric comment (handler data) + (:method ((handler t) data) data nil)) + +(defgeneric start-cdata (handler) + (:documentation "Called at the beginning of parsing a CDATA section. + +Handlers only have to implement this if they are interested in the +lexical structure of the parsed document. The content of the CDATA +section is reported via the `characters' generic function like all +other textual content.") + (:method ((handler t)) nil)) + +(defgeneric end-cdata (handler) + (:documentation "Called at the end of parsing a CDATA section. + +Handlers only have to implement this if they are interested in the +lexical structure of the parsed document. The content of the CDATA +section is reported via the `characters' generic function like all +other textual content.") + (:method ((handler t)) nil)) + +(defgeneric start-dtd (handler name public-id system-id) + (:documentation "Called at the beginning of parsing a DTD.") + (:method ((handler t) name public-id system-id) + (declare (ignore name public-id system-id)) + nil)) + +(defgeneric end-dtd (handler) + (:documentation "Called at the end of parsing a DTD.") + (:method ((handler t)) nil)) + +(defgeneric start-internal-subset (handler) + (:documentation "Reports that an internal subset is present. Called before +any definition from the internal subset is reported.") + (:method ((handler t)) nil)) + +(defgeneric end-internal-subset (handler) + (:documentation "Called after processing of the internal subset has +finished, if present.") + (:method ((handler t)) nil)) + +(defgeneric unparsed-internal-subset (handler str) + (:documentation "Reports that an internal subset is present, but has not +been parsed and is available as a string.") + (:method ((handler t) str) nil)) + +(defgeneric unparsed-entity-declaration + (handler name public-id system-id notation-name) + (:documentation + "Called when an unparsed entity declaration is seen in a DTD.") + (:method ((handler t) name public-id system-id notation-name) + (declare (ignore name public-id system-id notation-name)) + nil)) + +(defgeneric external-entity-declaration + (handler kind name public-id system-id) + (:documentation + "Called when a parsed external entity declaration is seen in a DTD.") + (:method ((handler t) kind name public-id system-id) + (declare (ignore kind name public-id system-id)) + nil)) + +(defgeneric internal-entity-declaration + (handler kind name value) + (:documentation + "Called when an internal entity declaration is seen in a DTD.") + (:method ((handler t) kind name value) + (declare (ignore kind name value)) + nil)) + +(defgeneric notation-declaration + (handler name public-id system-id) + (:documentation + "Called when a notation declaration is seen while parsing a DTD.") + (:method ((handler t) name public-id system-id) + (declare (ignore name public-id system-id)) + nil)) + +(defgeneric element-declaration (handler name model) + (:documentation + "Called when a element declaration is seen in a DTD. Model is not a string, + but a nested list, with *, ?, +, OR, and AND being the operators, rods + as names, :EMPTY and :PCDATA as special tokens. (AND represents + sequences.)") + (:method ((handler t) name model) + (declare (ignore name model)) + nil)) + +(defgeneric attribute-declaration + (handler element-name attribute-name type default) + (:documentation + "Called when an attribute declaration is seen in a DTD. + type one of :CDATA, :ID, :IDREF, :IDREFS, + :ENTITY, :ENTITIES, :NMTOKEN, :NMTOKENS, + (:NOTATION <name>*), or (:ENUMERATION <name>*) + default :REQUIRED, :IMPLIED, (:FIXED content), or (:DEFAULT content)") + (:method ((handler t) element-name attribute-name type value) + (declare (ignore element-name attribute-name type value)) + nil)) + +(defgeneric entity-resolver + (handler resolver) + (:documentation + "Called between sax:end-dtd and sax:end-document to register an entity + resolver, a function of two arguments: An entity name and SAX handler. + When called, the resolver function will parse the named entity's data.") + (:method ((handler t) resolver) + (declare (ignore resolver)) + nil)) + +(defgeneric register-sax-parser + (handler sax-parser) + (:documentation + "Set the SAX-PARSER instance of this handler.") + (:method ((handler t) sax-parser) + (declare (ignore sax-parser)) + nil) + (:method ((handler sax-parser-mixin) sax-parser) + (setf (slot-value handler 'sax-parser) sax-parser))) + +;; internal for now +(defgeneric dtd (handler dtd) + (:method ((handler t) dtd) (declare (ignore dtd)) nil)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-proxy.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-proxy.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-proxy.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,64 @@ +;;;; sax-proxy.lisp +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Copyright (c) 2004 David Lichteblau +;;;; Author: David Lichteblau + +(in-package :cxml) + +(defclass broadcast-handler (sax:sax-parser-mixin) + ((handlers :initform nil + :initarg :handlers + :accessor broadcast-handler-handlers))) + +(defun make-broadcast-handler (&rest handlers) + (make-instance 'broadcast-handler :handlers handlers)) + +(defclass sax-proxy (broadcast-handler) + ()) + +(defmethod initialize-instance + :after ((instance sax-proxy) &key chained-handler) + (setf (proxy-chained-handler instance) chained-handler)) + +(defmethod proxy-chained-handler ((instance sax-proxy)) + (car (broadcast-handler-handlers instance))) + +(defmethod (setf proxy-chained-handler) (newval (instance sax-proxy)) + (setf (broadcast-handler-handlers instance) (list newval))) + +(macrolet ((define-proxy-method (name (&rest args)) + `(defmethod ,name ((handler broadcast-handler) ,@args) + (let (result) + (dolist (next (broadcast-handler-handlers handler)) + (setf result (,name next ,@args))) + result)))) + (define-proxy-method sax:start-document ()) + (define-proxy-method sax:start-element (uri lname qname attributes)) + (define-proxy-method sax:start-prefix-mapping (prefix uri)) + (define-proxy-method sax:characters (data)) + (define-proxy-method sax:processing-instruction (target data)) + (define-proxy-method sax:end-prefix-mapping (prefix)) + (define-proxy-method sax:end-element (namespace-uri local-name qname)) + (define-proxy-method sax:end-document ()) + (define-proxy-method sax:comment (data)) + (define-proxy-method sax:start-cdata ()) + (define-proxy-method sax:end-cdata ()) + (define-proxy-method sax:start-dtd (name public-id system-id)) + (define-proxy-method sax:end-dtd ()) + (define-proxy-method sax:start-internal-subset ()) + (define-proxy-method sax:end-internal-subset ()) + (define-proxy-method sax:unparsed-entity-declaration (name pub sys not)) + (define-proxy-method sax:external-entity-declaration (kind name pub sys)) + (define-proxy-method sax:internal-entity-declaration (kind name value)) + (define-proxy-method sax:notation-declaration (name public-id system-id)) + (define-proxy-method sax:element-declaration (name model)) + (define-proxy-method sax:attribute-declaration (elt attr type default)) + (define-proxy-method sax:entity-resolver (resolver)) + (define-proxy-method sax::dtd (dtd))) + +(defmethod sax:register-sax-parser :after ((handler broadcast-handler) parser) + (dolist (next (broadcast-handler-handlers handler)) + (sax:register-sax-parser next parser))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/Entries 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/Entries 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,4 @@ +/event-collecting-handler.lisp/1.1.1.1/Sun Mar 13 18:02:10 2005// +/package.lisp/1.1.1.1/Sun Mar 13 18:02:10 2005// +/tests.lisp/1.2/Wed Dec 28 23:18:07 2005// +D Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/Repository 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/Repository 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +cxml/xml/sax-tests Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/Root 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/CVS/Root 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1 @@ +:ext:dlichteblau@common-lisp.net:/project/cxml/cvsroot Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/event-collecting-handler.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/event-collecting-handler.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/event-collecting-handler.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,37 @@ +(in-package :sax-tests) + +(defclass event-collecting-handler () + ((event-list :initform '() :accessor event-list))) + +(defmethod start-document ((handler event-collecting-handler)) + (push (list :start-document) (event-list handler))) + +(defmethod start-element ((handler event-collecting-handler) ns-uri local-name qname attrs) + (push (list :start-element ns-uri local-name qname attrs) + (event-list handler))) + +(defmethod start-prefix-mapping ((handler event-collecting-handler) prefix uri) + (push (list :start-prefix-mapping prefix uri) + (event-list handler))) + +(defmethod characters ((handler event-collecting-handler) data) + (push (list :characters data) + (event-list handler))) + +(defmethod processing-instruction ((handler event-collecting-handler) target data) + (push (list :processing-instruction target data) + (event-list handler))) + +(defmethod end-prefix-mapping ((handler event-collecting-handler) prefix) + (push (list :end-prefix-mapping prefix) + (event-list handler))) + +(defmethod end-element ((handler event-collecting-handler) namespace-uri local-name qname) + (push (list :end-element namespace-uri local-name qname) + (event-list handler))) + +(defmethod end-document ((handler event-collecting-handler)) + (push (list :end-document) + (event-list handler)) + + (nreverse (event-list handler))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/package.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/package.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,4 @@ +(defpackage :sax-tests + (:use :cl :xml :sax :glisp :rt) + (:export #:event-collecting-handler)) + Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/tests.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/tests.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/sax-tests/tests.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,330 @@ +(in-package :sax-tests) + +(defun first-start-element-event (string) + (let ((events (cxml:parse-rod string (make-instance 'event-collecting-handler)))) + (find :start-element events :key #'car))) + + +;;; Attribute handling + +(deftest no-default-namespace-for-attributes + (let* ((evt (first-start-element-event "<x xmlns='http://example.com' a='b'/>")) + (attr (car (fifth evt)))) + (values + (attribute-namespace-uri attr) + (attribute-local-name attr))) + nil nil) + +(deftest attribute-uniqueness-1 + (handler-case + (cxml:parse-rod "<x xmlns:a='http://example.com' xmlns:b='http://example.com' a:a='1' b:a='1'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest attribute-uniqueness-2 + (handler-case + (cxml:parse-rod "<x xmlns:a='http://example.com' xmlns='http://example.com' a:a='1' a='1'/>") + (error () nil) + (:no-error (&rest junk) + (declare (ignore junk)) + t)) + t) + +(deftest attribute-uniqueness-3 + (let ((sax:*namespace-processing* nil)) + (handler-case + (cxml:parse-rod "<x xmlns:a='http://example.com' xmlns:b='http://example.com' a:a='1' b:a='1'/>") + (error () nil) + (:no-error (&rest junk) + (declare (ignore junk)) + t))) + t) + +;;; Namespace undeclaring + +(deftest undeclare-default-namespace-1 + (let* ((evts (cxml:parse-rod "<x xmlns='http://example.com'><y xmlns='' a='1'/></x>" + (make-instance 'event-collecting-handler))) + (start-elt-events (remove :start-element evts :test (complement #'eql) :key #'car)) + (evt1 (first start-elt-events)) + (evt2 (second start-elt-events ))) + (values + (rod= #"http://example.com" (second evt1)) + (second evt2) + (third evt2))) + t nil nil) + +(deftest undeclare-other-namespace + (handler-case + (cxml:parse-rod "<x:x xmlns:x='http://example.com'><x:y xmlns:x='' a='1'/></x:x>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + + +;;; Require names otherwise totally out of scope of the xmlns rec to be NcNames for no reason + +(deftest pi-names-are-ncnames-when-namespace-processing-1 + (handler-case + (cxml:parse-rod "<?a:b c?><x/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest pi-names-are-ncnames-when-namespace-processing-2 + (let ((sax:*namespace-processing* nil)) + (handler-case + (cxml:parse-rod "<?a:b c?><x/>") + (error () nil) + (:no-error (&rest junk) + (declare (ignore junk)) + t))) + t) + +(deftest entity-names-are-ncnames-when-namespace-processing-1 + (handler-case + (cxml:parse-rod "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x>&y:z;</x>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest entity-names-are-ncnames-when-namespace-processing-2 + (handler-case + (cxml:parse-rod "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest entity-names-are-ncnames-when-namespace-processing-3 + (let ((sax:*namespace-processing* nil)) + (handler-case + (cxml:parse-rod "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x>&y:z;</x>") + (error () nil) + (:no-error (&rest junk) + (declare (ignore junk)) + t))) + t) + +(deftest entity-names-are-ncnames-when-namespace-processing-4 + (let ((sax:*namespace-processing* nil)) + (handler-case + (cxml:parse-rod "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x/>") + (error () nil) + (:no-error (&rest junk) + (declare (ignore junk)) + t))) + t) + +;;; Inclusion of xmlns attributes + +(deftest xmlns-attr-include-1 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (length attrs)) + 1) + +(deftest xmlns-attr-discard-1 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* nil) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (length attrs)) + 0) + +;;; Namespace of xmlns attributes + +(deftest xmlns-attr-ns-uri-1 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* nil) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (attribute-namespace-uri (car attrs))) + nil) + +(deftest xmlns-attr-ns-uri-2 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* nil) + (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>")) + (attrs (fifth evt))) + (attribute-namespace-uri (car attrs))) + nil) + +(deftest xmlns-attr-ns-uri-3 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* t) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (attribute-namespace-uri (car attrs))) + nil) + +(deftest xmlns-attr-ns-uri-4 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* t) + (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>")) + (attrs (fifth evt))) + (rod= #"http://www.w3.org/2000/xmlns/" (attribute-namespace-uri (car attrs)))) + t) + +(deftest xmlns-attr-ns-local-name-1 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* nil) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (attribute-local-name (car attrs))) + nil) + +(deftest xmlns-attr-ns-local-name-2 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* nil) + (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>")) + (attrs (fifth evt))) + (attribute-local-name (car attrs))) + nil) + +(deftest xmlns-attr-ns-local-name-3 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* t) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (attribute-local-name (car attrs))) + nil) + +(deftest xmlns-attr-ns-local-name-4 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* t) + (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>")) + (attrs (fifth evt))) + (rod= #"foo" (attribute-local-name (car attrs)))) + t) + +(deftest xmlns-attr-qname-1 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* nil) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (rod= #"xmlns" (attribute-qname (car attrs)))) + t) + +(deftest xmlns-attr-qname-2 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* nil) + (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>")) + (attrs (fifth evt))) + (rod= #"xmlns:foo" (attribute-qname (car attrs)))) + t) + +(deftest xmlns-attr-qname-4 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* t) + (evt (first-start-element-event "<x xmlns='http://example.com'/>")) + (attrs (fifth evt))) + (rod= #"xmlns" (attribute-qname (car attrs)))) + t) + +(deftest xmlns-attr-qname-4 + (let* ((sax:*namespace-processing* t) + (sax:*include-xmlns-attributes* t) + (sax:*use-xmlns-namespace* t) + (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>")) + (attrs (fifth evt))) + (rod= #"xmlns:foo" (attribute-qname (car attrs)))) + t) + + +;;; Predefined Namespaces + +(deftest redefine-xml-namespace-1 + (handler-case + (cxml:parse-rod "<x xmlns:xml='http://www.w3.org/XML/1998/namespace'/>") + (error () nil) + (:no-error (&rest junk) + (declare (ignore junk)) + t)) + t) + +(deftest redefine-xml-namespace-2 + (handler-case + (cxml:parse-rod "<x xmlns:xml='http://example.com/wrong-uri'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest redefine-xml-namespace-3 + (handler-case + (cxml:parse-rod "<x xmlns:wrong='http://www.w3.org/XML/1998/namespace'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest redefine-xml-namespace-4 + (handler-case + (cxml:parse-rod "<x xmlns:wrong='http://www.w3.org/XML/1998/namespace'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest redefine-xmlns-namespace-1 + (handler-case + (cxml:parse-rod "<x xmlns:xmlns='http://www.w3.org/2000/xmlns/'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest redefine-xmlns-namespace-2 + (handler-case + (cxml:parse-rod "<x xmlns:xmlns='http://example.com/wrong-ns'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest redefine-xmlns-namespace-3 + (handler-case + (cxml:parse-rod "<x xmlns:wrong='http://www.w3.org/2000/xmlns/'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) + +(deftest redefine-xmlns-namespace-4 + (handler-case + (cxml:parse-rod "<x xmlns='http://www.w3.org/2000/xmlns/'/>") + (error () t) + (:no-error (&rest junk) + (declare (ignore junk)) + nil)) + t) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/space-normalizer.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/space-normalizer.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/space-normalizer.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,62 @@ +;;;; space-normalizer.lisp -- whitespace removal +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Copyright (c) 2005 David Lichteblau + +(in-package :cxml) + +(defclass whitespace-normalizer (sax-proxy) + ((attributes :initform '(t) :accessor xml-space-attributes) + (models :initform nil :accessor xml-space-models) + (dtd :initarg :dtd :accessor xml-space-dtd))) + +(defun make-whitespace-normalizer (chained-handler &optional dtd) + (make-instance 'whitespace-normalizer + :dtd dtd + :chained-handler chained-handler)) + +(defmethod sax::dtd ((handler whitespace-normalizer) dtd) + (unless (xml-space-dtd handler) + (setf (xml-space-dtd handler) dtd))) + +(defmethod sax:start-element + ((handler whitespace-normalizer) uri lname qname attrs) + (declare (ignore uri lname)) + (let ((dtd (xml-space-dtd handler))) + (when dtd + (let ((xml-space + (sax:find-attribute (if (stringp qname) "xml:space" #"xml:space") + attrs))) + (push (if xml-space + (rod= (rod (sax:attribute-value xml-space)) #"default") + (car (xml-space-attributes handler))) + (xml-space-attributes handler))) + (let* ((e (cxml::find-element (rod qname) dtd)) + (cspec (when e (cxml::elmdef-content e)))) + (push (and (consp cspec) + (not (and (eq (car cspec) '*) + (let ((subspec (second cspec))) + (and (eq (car subspec) 'or) + (eq (cadr subspec) :PCDATA)))))) + (xml-space-models handler))))) + (call-next-method)) + +(defmethod sax:characters ((handler whitespace-normalizer) data) + (cond + ((and (xml-space-dtd handler) + (car (xml-space-attributes handler)) + (car (xml-space-models handler))) + (unless (every #'white-space-rune-p (rod data)) + (warn "non-whitespace character data in element content") + (call-next-method))) + (t + (call-next-method)))) + +(defmethod sax:end-element ((handler whitespace-normalizer) uri lname qname) + (declare (ignore uri lname qname)) + (when (xml-space-dtd handler) + (pop (xml-space-attributes handler)) + (pop (xml-space-models handler))) + (call-next-method)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/split-sequence.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/split-sequence.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/split-sequence.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,44 @@ +;;; This code was based on Arthur Lemmens' in +;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>; + +(in-package :cxml) + +(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/unparse.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/unparse.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/unparse.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,673 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CXML; readtable: runes; Encoding: utf-8; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Unparse XML +;;; Title: (including support for canonic XML according to J.Clark) +;;; Created: 1999-09-09 +;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;; Author: David Lichteblau <david(a)lichteblau.com> +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1999 by Gilbert Baumann +;;; (c) copyright 2004 by knowledgeTools Int. GmbH +;;; (c) copyright 2004 by David Lichteblau (for headcraft.de) + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 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 +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library 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. + +(in-package :cxml) + +;; +;; | Canonical XML +;; | ============= +;; | +;; | This document defines a subset of XML called canonical XML. The +;; | intended use of canonical XML is in testing XML processors, as a +;; | representation of the result of parsing an XML document. +;; | +;; | Every well-formed XML document has a unique structurally equivalent +;; | canonical XML document. Two structurally equivalent XML documents have +;; | a byte-for-byte identical canonical XML document. Canonicalizing an +;; | XML document requires only information that an XML processor is +;; | required to make available to an application. +;; | +;; | A canonical XML document conforms to the following grammar: +;; | +;; | CanonXML ::= Pi* element Pi* +;; | element ::= Stag (Datachar | Pi | element)* Etag +;; | Stag ::= '<' Name Atts '>' +;; | Etag ::= '</' Name '>' +;; | Pi ::= '<?' Name ' ' (((Char - S) Char*)? - (Char* '?>' Char*)) '?>' +;; | Atts ::= (' ' Name '=' '"' Datachar* '"')* +;; | Datachar ::= '&' | '<' | '>' | '"' +;; | | '	'| '
'| '' +;; | | (Char - ('&' | '<' | '>' | '"' | #x9 | #xA | #xD)) +;; | Name ::= (see XML spec) +;; | Char ::= (see XML spec) +;; | S ::= (see XML spec) +;; | +;; | Attributes are in lexicographical order (in Unicode bit order). +;; | +;; | A canonical XML document is encoded in UTF-8. +;; | +;; | Ignorable white space is considered significant and is treated +;; | equivalently to data. +;; +;; -- James Clark (jjc(a)jclark.com) + + +;;;; SINK: an xml output sink + +(defclass sink () + ((ystream :initarg :ystream :accessor sink-ystream) + (width :initform 79 :initarg :width :accessor width) + (canonical :initform nil :initarg :canonical :accessor canonical) + (indentation :initform nil :initarg :indentation :accessor indentation) + (current-indentation :initform 0 :accessor current-indentation) + (notations :initform (make-buffer :element-type t) :accessor notations) + (name-for-dtd :accessor name-for-dtd) + (previous-notation :initform nil :accessor previous-notation) + (have-doctype :initform nil :accessor have-doctype) + (have-internal-subset :initform nil :accessor have-internal-subset) + (stack :initform nil :accessor stack))) + +(defmethod initialize-instance :after ((instance sink) &key) + (when (eq (canonical instance) t) + (setf (canonical instance) 1)) + (unless (member (canonical instance) '(nil 1 2)) + (error "Invalid canonical form: ~A" (canonical instance))) + (when (and (canonical instance) (indentation instance)) + (error "Cannot indent XML in canonical mode"))) + +(defun make-buffer (&key (element-type '(unsigned-byte 8))) + (make-array 1 + :element-type element-type + :adjustable t + :fill-pointer 0)) + +;; bisschen unschoen hier die ganze api zu duplizieren, aber die +;; ystreams sind noch undokumentiert +(macrolet ((define-maker (make-sink make-ystream &rest args) + `(defun ,make-sink (,@args &rest initargs) + (apply #'make-instance + 'sink + :ystream (,make-ystream ,@args) + initargs)))) + (define-maker make-octet-vector-sink make-octet-vector-ystream) + (define-maker make-octet-stream-sink make-octet-stream-ystream stream) + (define-maker make-rod-sink make-rod-ystream) + + #+rune-is-character + (define-maker make-character-stream-sink make-character-stream-ystream stream) + + #-rune-is-character + (define-maker make-string-sink/utf8 make-string-ystream/utf8) + + #-rune-is-character + (define-maker make-character-stream-sink/utf8 + make-character-stream-ystream/utf8 + stream)) + +#+rune-is-character +(defun make-string-sink (&rest args) (apply #'make-rod-sink args)) + + +(defmethod sax:end-document ((sink sink)) + (close-ystream (sink-ystream sink))) + + +;;;; doctype and notations + +(defmethod sax:start-document ((sink sink)) + (unless (canonical sink) + (%write-rod #"<?xml version=\"1.0\" encoding=\"UTF-8\"?>" sink) + (%write-rune #/U+000A sink))) + +(defmethod sax:start-dtd ((sink sink) name public-id system-id) + (setf (name-for-dtd sink) name) + (unless (canonical sink) + (ensure-doctype sink public-id system-id))) + +(defun ensure-doctype (sink &optional public-id system-id) + (unless (have-doctype sink) + (setf (have-doctype sink) t) + (%write-rod #"<!DOCTYPE " sink) + (%write-rod (name-for-dtd sink) sink) + (cond + ((not (zerop (length public-id))) + (%write-rod #" PUBLIC \"" sink) + (unparse-string public-id sink) + (%write-rod #"\" \"" sink) + (unparse-string system-id sink) + (%write-rod #"\"" sink)) + ((not (zerop (length system-id))) + (%write-rod #" SYSTEM \"" sink) + (unparse-string system-id sink) + (%write-rod #"\"" sink))))) + +(defmethod sax:start-internal-subset ((sink sink)) + (when (have-internal-subset sink) + (error "duplicate internal subset")) + (setf (have-internal-subset sink) t) + (ensure-doctype sink) + (%write-rod #" [" sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:end-internal-subset ((sink sink)) + (ensure-doctype sink) + (%write-rod #"]" sink)) + +(defmethod sax:unparsed-internal-subset ((sink sink) str) + (when (have-internal-subset sink) + (error "duplicate internal subset")) + (setf (have-internal-subset sink) t) + (ensure-doctype sink) + (%write-rod #" [" sink) + (%write-rune #/U+000A sink) + (%write-rod str sink) + (%write-rod #"]" sink)) + +;; for the benefit of the XML test suite, prefer ' over " +(defun write-quoted-rod (x sink) + (let ((q (if (find #/' x) #/" #/' + ;; '" (thanks you Emacs indentation, the if ends here) + ))) + (%write-rune q sink) + (%write-rod x sink) + (%write-rune q sink))) + +(defmethod sax:notation-declaration ((sink sink) name public-id system-id) + (let ((prev (previous-notation sink))) + (when (and (and (canonical sink) (>= (canonical sink) 2)) + prev + (not (rod< prev name))) + (error "misordered notations; cannot unparse canonically")) + (setf (previous-notation sink) name)) + (%write-rod #"<!NOTATION " sink) + (%write-rod name sink) + (cond + ((zerop (length public-id)) + (%write-rod #" SYSTEM " sink) + (write-quoted-rod system-id sink)) + ((zerop (length system-id)) + (%write-rod #" PUBLIC " sink) + (write-quoted-rod public-id sink)) + (t + (%write-rod #" PUBLIC " sink) + (write-quoted-rod public-id sink) + (%write-rod #" " sink) + (write-quoted-rod system-id sink))) + (%write-rune #/> sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:unparsed-entity-declaration + ((sink sink) name public-id system-id notation-name) + (unless (and (canonical sink) (< (canonical sink) 3)) + (%write-rod #"<!ENTITY " sink) + (%write-rod name sink) + (cond + ((zerop (length public-id)) + (%write-rod #" SYSTEM " sink) + (write-quoted-rod system-id sink)) + ((zerop (length system-id)) + (%write-rod #" PUBLIC " sink) + (write-quoted-rod public-id sink)) + (t + (%write-rod #" PUBLIC " sink) + (write-quoted-rod public-id sink) + (%write-rod #" " sink) + (write-quoted-rod system-id sink))) + (%write-rod #" NDATA " sink) + (%write-rod notation-name sink) + (%write-rune #/> sink) + (%write-rune #/U+000A sink))) + +(defmethod sax:external-entity-declaration + ((sink sink) kind name public-id system-id) + (when (canonical sink) + (error "cannot serialize parsed entities in canonical mode")) + (%write-rod #"<!ENTITY " sink) + (when (eq kind :parameter) + (%write-rod #" % " sink)) + (%write-rod name sink) + (cond + ((zerop (length public-id)) + (%write-rod #" SYSTEM " sink) + (write-quoted-rod system-id sink)) + ((zerop (length system-id)) + (%write-rod #" PUBLIC " sink) + (write-quoted-rod public-id sink)) + (t + (%write-rod #" PUBLIC " sink) + (write-quoted-rod public-id sink) + (%write-rod #" " sink) + (write-quoted-rod system-id sink))) + (%write-rune #/> sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:internal-entity-declaration ((sink sink) kind name value) + (when (canonical sink) + (error "cannot serialize parsed entities in canonical mode")) + (%write-rod #"<!ENTITY " sink) + (when (eq kind :parameter) + (%write-rod #" % " sink)) + (%write-rod name sink) + (%write-rune #/U+0020 sink) + (%write-rune #/\" sink) + (unparse-dtd-string value sink) + (%write-rune #/\" sink) + (%write-rune #/> sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:element-declaration ((sink sink) name model) + (when (canonical sink) + (error "cannot serialize element type declarations in canonical mode")) + (%write-rod #"<!ELEMENT " sink) + (%write-rod name sink) + (%write-rune #/U+0020 sink) + (labels ((walk (m) + (cond + ((eq m :EMPTY) + (%write-rod "EMPTY" sink)) + ((eq m :PCDATA) + (%write-rod "#PCDATA" sink)) + ((atom m) + (unparse-string m sink)) + (t + (ecase (car m) + (and + (%write-rune #/$ sink) + (loop for (n . rest) on (cdr m) do + (walk n) + (when rest + (%write-rune #\, sink))) + (%write-rune #/$ sink)) + (or + (%write-rune #/$ sink) + (loop for (n . rest) on (cdr m) do + (walk n) + (when rest + (%write-rune #\| sink))) + (%write-rune #/$ sink)) + (* + (walk (second m)) + (%write-rod #/* sink)) + (+ + (walk (second m)) + (%write-rod #/+ sink)) + (? + (walk (second m)) + (%write-rod #/? sink))))))) + (walk model)) + (%write-rune #/> sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:attribute-declaration ((sink sink) ename aname type default) + (when (canonical sink) + (error "cannot serialize attribute type declarations in canonical mode")) + (%write-rod #"<!ATTLIST " sink) + (%write-rod ename sink) + (%write-rune #/U+0020 sink) + (%write-rod aname sink) + (%write-rune #/U+0020 sink) + (cond + ((atom type) + (%write-rod (rod (string-upcase (symbol-name type))) sink)) + (t + (when (eq :NOTATION (car type)) + (%write-rod #"NOTATION " sink)) + (%write-rune #/$ sink) + (loop for (n . rest) on (cdr type) do + (%write-rod n sink) + (when rest + (%write-rune #\| sink))) + (%write-rune #/$ sink))) + (%write-rune #/U+0020 sink) + (cond + ((atom default) + (%write-rune #/# sink) + (%write-rod (rod (string-upcase (symbol-name default))) sink)) + (t + (when (eq :FIXED (car default)) + (%write-rod #"#FIXED " sink)) + (%write-rune #/\" sink) + (unparse-string (second default) sink) + (%write-rune #/\" sink))) + (%write-rune #/> sink) + (%write-rune #/U+000A sink)) + +(defmethod sax:end-dtd ((sink sink)) + (when (have-doctype sink) + (%write-rod #">" sink) + (%write-rune #/U+000A sink))) + + +;;;; elements + +(defstruct (tag (:constructor make-tag (name))) + name + (n-children 0) + (have-gt nil)) + +(defun sink-fresh-line (sink) + (unless (zerop (ystream-column (sink-ystream sink))) + (%write-rune #/U+000A sink) ;newline + (indent sink))) + +(defun maybe-close-tag (sink) + (let ((tag (car (stack sink)))) + (when (and (tag-p tag) (not (tag-have-gt tag))) + (setf (tag-have-gt tag) t) + (%write-rune #/> sink)))) + +(defmethod sax:start-element + ((sink sink) namespace-uri local-name qname attributes) + (declare (ignore namespace-uri local-name)) + (maybe-close-tag sink) + (when (stack sink) + (incf (tag-n-children (first (stack sink))))) + (push (make-tag qname) (stack sink)) + (when (indentation sink) + (sink-fresh-line sink) + (start-indentation-block sink)) + (%write-rune #/< sink) + (%write-rod qname sink) + (dolist (a (if (canonical sink) + (sort (copy-list attributes) + #'rod< + :key #'sax:attribute-qname) + attributes)) + (%write-rune #/space sink) + (%write-rod (sax:attribute-qname a) sink) + (%write-rune #/= sink) + (%write-rune #/\" sink) + (unparse-string (sax:attribute-value a) sink) + (%write-rune #/\" sink)) + (when (canonical sink) + (maybe-close-tag sink))) + +(defmethod sax:end-element + ((sink sink) namespace-uri local-name qname) + (declare (ignore namespace-uri local-name)) + (let ((tag (pop (stack sink)))) + (unless (tag-p tag) + (error "output does not nest: not in an element")) + (unless (rod= (tag-name tag) qname) + (error "output does not nest: expected ~A but got ~A" + (rod qname) (rod (tag-name tag)))) + (when (indentation sink) + (end-indentation-block sink) + (unless (zerop (tag-n-children tag)) + (sink-fresh-line sink))) + (cond + ((tag-have-gt tag) + (%write-rod '#.(string-rod "</") sink) + (%write-rod qname sink) + (%write-rod '#.(string-rod ">") sink)) + (t + (%write-rod #"/>" sink))))) + +(defmethod sax:processing-instruction ((sink sink) target data) + (maybe-close-tag sink) + (unless (rod-equal target '#.(string-rod "xml")) + (%write-rod '#.(string-rod "<?") sink) + (%write-rod target sink) + (cond + ((plusp (length data)) + (%write-rune #/space sink) + (%write-rod data sink)) + ((canonical sink) + (%write-rune #/space sink))) + (%write-rod '#.(string-rod "?>") sink))) + +(defmethod sax:start-cdata ((sink sink)) + (maybe-close-tag sink) + (push :cdata (stack sink))) + +(defmethod sax:characters ((sink sink) data) + (maybe-close-tag sink) + (cond + ((and (eq (car (stack sink)) :cdata) + (not (canonical sink)) + (not (search #"]]" data))) + (when (indentation sink) + (sink-fresh-line sink)) + (%write-rod #"<![CDATA[" sink) + ;; XXX signal error if body is unprintable? + (map nil (lambda (c) (%write-rune c sink)) data) + (%write-rod #"]]>" sink)) + (t + (if (indentation sink) + (unparse-indented-text data sink) + (let ((y (sink-ystream sink))) + (if (canonical sink) + (loop for c across data do (unparse-datachar c y)) + (loop for c across data do (unparse-datachar-readable c y)))))))) + +(defmethod sax:comment ((sink sink) data) + (maybe-close-tag sink) + (unless (canonical sink) + ;; XXX signal error if body is unprintable? + (%write-rod #"" sink))) + +(defmethod sax:end-cdata ((sink sink)) + (unless (eq (pop (stack sink)) :cdata) + (error "output does not nest: not in a cdata section"))) + +(defun indent (sink) + (dotimes (x (current-indentation sink)) + (%write-rune #/U+0020 sink))) ; space + +(defun start-indentation-block (sink) + (incf (current-indentation sink) (indentation sink))) + +(defun end-indentation-block (sink) + (decf (current-indentation sink) (indentation sink))) + +(defun unparse-indented-text (data sink) + (flet ((whitespacep (x) + (or (rune= x #/U+000A) (rune= x #/U+0020)))) + (let* ((n (length data)) + (pos (position-if-not #'whitespacep data)) + (need-whitespace-p nil)) + (cond + ((zerop n)) + (pos + (sink-fresh-line sink) + (while (< pos n) + (let* ((w (or (position-if #'whitespacep data :start (1+ pos)) n)) + (next (or (position-if-not #'whitespacep data :start w) n))) + (when need-whitespace-p + (if (< (+ (ystream-column (sink-ystream sink)) w (- pos)) + (width sink)) + (%write-rune #/U+0020 sink) + (sink-fresh-line sink))) + (loop + with y = (sink-ystream sink) + for i from pos below w do + (unparse-datachar-readable (elt data i) y)) + (setf need-whitespace-p (< w n)) + (setf pos next)))) + (t + (%write-rune #/U+0020 sink)))))) + +(defun unparse-string (str sink) + (let ((y (sink-ystream sink))) + (loop for rune across str do (unparse-datachar rune y)))) + +(defun unparse-datachar (c ystream) + (cond ((rune= c #/&) (write-rod '#.(string-rod "&") ystream)) + ((rune= c #/<) (write-rod '#.(string-rod "<") ystream)) + ((rune= c #/>) (write-rod '#.(string-rod ">") ystream)) + ((rune= c #/\") (write-rod '#.(string-rod """) ystream)) + ((rune= c #/U+0009) (write-rod '#.(string-rod "	") ystream)) + ((rune= c #/U+000A) (write-rod '#.(string-rod "
") ystream)) + ((rune= c #/U+000D) (write-rod '#.(string-rod "") ystream)) + (t + (write-rune c ystream)))) + +(defun unparse-datachar-readable (c ystream) + (cond ((rune= c #/&) (write-rod '#.(string-rod "&") ystream)) + ((rune= c #/<) (write-rod '#.(string-rod "<") ystream)) + ((rune= c #/>) (write-rod '#.(string-rod ">") ystream)) + ((rune= c #/\") (write-rod '#.(string-rod """) ystream)) + ((rune= c #/U+000D) (write-rod '#.(string-rod "") ystream)) + (t + (write-rune c ystream)))) + +(defun unparse-dtd-string (str sink) + (let ((y (sink-ystream sink))) + (loop for rune across str do (unparse-dtd-char rune y)))) + +(defun unparse-dtd-char (c ystream) + (cond ((rune= c #/%) (write-rod '#.(string-rod "%") ystream)) + ((rune= c #/&) (write-rod '#.(string-rod "&") ystream)) + ((rune= c #/<) (write-rod '#.(string-rod "<") ystream)) + ((rune= c #/>) (write-rod '#.(string-rod ">") ystream)) + ((rune= c #/\") (write-rod '#.(string-rod """) ystream)) + ((rune= c #/U+0009) (write-rod '#.(string-rod "	") ystream)) + ((rune= c #/U+000A) (write-rod '#.(string-rod "
") ystream)) + ((rune= c #/U+000D) (write-rod '#.(string-rod "") ystream)) + (t + (write-rune c ystream)))) + +(defun %write-rune (c sink) + (write-rune c (sink-ystream sink))) + +(defun %write-rod (r sink) + (write-rod r (sink-ystream sink))) + + +;;;; convenience functions for DOMless XML serialization + +(defvar *current-element*) +(defvar *sink*) +(defvar *unparse-namespace-bindings*) +(defvar *current-namespace-bindings*) + +(defmacro with-xml-output (sink &body body) + `(invoke-with-xml-output (lambda () ,@body) ,sink)) + +(defun invoke-with-xml-output (fn sink) + (let ((*sink* sink) + (*current-element* nil) + (*unparse-namespace-bindings* *initial-namespace-bindings*) + (*current-namespace-bindings* nil)) + (sax:start-document *sink*) + (funcall fn) + (sax:end-document *sink*))) + +(defmacro with-element (qname &body body) + `(invoke-with-element (lambda () ,@body) ,qname)) + +(defmacro with-element* ((prefix lname) &body body) + `(invoke-with-element* (lambda () ,@body) ,prefix ,lname)) + +(defmacro with-namespace ((prefix uri) &body body) + `(invoke-with-namespace (lambda () ,@body) ,prefix ,uri)) + +(defun doctype (name public-id system-id &optional internal-subset) + (sax:start-dtd *sink* name public-id system-id) + (when internal-subset + (sax:unparsed-internal-subset *sink* internal-subset)) + (sax:end-dtd *sink*)) + +(defun maybe-emit-start-tag () + (when *current-element* + ;; starting child node, need to emit opening tag of parent first: + (destructuring-bind ((uri lname qname) &rest attributes) *current-element* + (sax:start-element *sink* uri lname qname (reverse attributes))) + (setf *current-element* nil))) + +(defun invoke-with-namespace (fn prefix uri) + (let ((*unparse-namespace-bindings* + (acons prefix uri *unparse-namespace-bindings*)) + (*current-namespace-bindings* + (acons prefix uri *current-namespace-bindings*))) + (sax:start-prefix-mapping *sink* prefix uri) + (multiple-value-prog1 + (funcall fn) + (sax:end-prefix-mapping *sink* prefix)))) + +(defun invoke-with-element (fn qname) + (setf qname (rod qname)) + (multiple-value-bind (prefix lname) + (split-qname qname) + (invoke-with-element* fn prefix lname qname))) + +(defun find-unparse-namespace (prefix) + (cdr (assoc prefix *unparse-namespace-bindings* :test 'equal))) + +(defun invoke-with-element* (fn prefix lname &optional qname) + (setf prefix (when prefix (rod prefix))) + (setf lname (rod lname)) + (maybe-emit-start-tag) + (let* ((qname (or qname + (if prefix (concatenate 'rod prefix #":" lname) lname))) + (uri (find-unparse-namespace (or prefix #""))) + (*current-element* + (cons (list uri lname qname) + (mapcar (lambda (x) + (destructuring-bind (prefix &rest uri) x + (sax:make-attribute + :namespace-uri #"http://www.w3.org/2000/xmlns/" + :local-name prefix + :qname (if (zerop (length prefix)) + #"xmlns" + (concatenate 'rod #"xmlns:" prefix)) + :value uri))) + *current-namespace-bindings*)))) + (multiple-value-prog1 + (let ((*current-namespace-bindings* nil)) + (funcall fn)) + (maybe-emit-start-tag) + (sax:end-element *sink* uri lname qname)))) + +(defgeneric unparse-attribute (value)) +(defmethod unparse-attribute ((value string)) value) +(defmethod unparse-attribute ((value null)) nil) +(defmethod unparse-attribute ((value integer)) (write-to-string value)) + +(defun attribute (qname value) + (setf qname (rod qname)) + (multiple-value-bind (prefix lname) + (split-qname qname) + (attribute* prefix lname value qname))) + +(defun attribute* (prefix lname value &optional qname) + (setf value (unparse-attribute value)) + (when value + (setf prefix (when prefix (rod prefix))) + (setf lname (rod lname)) + (push (sax:make-attribute + :namespace-uri (find-unparse-namespace prefix) + :local-name lname + :qname (or qname + (if prefix (concatenate 'rod prefix #":" lname) lname)) + :value (rod value)) + (cdr *current-element*)))) + +(defun cdata (data) + (maybe-emit-start-tag) + (sax:start-cdata *sink*) + (sax:characters *sink* (rod data)) + (sax:end-cdata *sink*) + data) + +(defun text (data) + (maybe-emit-start-tag) + (sax:characters *sink* (rod data)) + data) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/util.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/util.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/util.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,73 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RUNES; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Some common utilities for the Closure browser +;;; Created: 1997-12-27 +;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1997-1999 by Gilbert Baumann + +;;; 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 to the Gnu Lesser General Public License" found in +;;; the file COPYING. +;;; +;;; 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. +;;; +;;; Version 2.1 of the GNU Lesser General Public License is in the file +;;; COPYING that was distributed with this file. If it is not present, +;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until +;;; superseded by a newer version) or write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;; Changes +;; +;; When Who What +;; ---------------------------------------------------------------------------- +;; 1999-08-24 GB = fixed MULTIPLE-VALUE-OR it now takes any number of +;; subforms +;; + +(in-package :cxml) + +;;; -------------------------------------------------------------------------------- +;;; Meta functions + +(defun curry (fun &rest args) + #'(lambda (&rest more) + (apply fun (append args more)))) + +(defun rcurry (fun &rest args) + #'(lambda (&rest more) + (apply fun (append more args)))) + +(defun compose (f g) + #'(lambda (&rest args) + (funcall f (apply g args)))) + +;;; -------------------------------------------------------------------------------- +;;; while and until + +(defmacro while (test &body body) + `(until (not ,test) ,@body)) + +(defmacro until (test &body body) + `(do () (,test) ,@body)) + +;; prime numbers + +(defun primep (n) + "Returns true, iff `n' is prime." + (and (> n 2) + (do ((i 2 (+ i 1))) + ((> (* i i) n) t) + (cond ((zerop (mod n i)) (return nil)))))) + +(defun nearest-greater-prime (n) + "Returns the smallest prime number no less than `n'." + (cond ((primep n) n) + ((nearest-greater-prime (+ n 1))))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xml-name-rune-p.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xml-name-rune-p.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xml-name-rune-p.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,185 @@ +;;;; xml-name-rune-p -- character class definitions +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> + +(in-package :cxml) + +#.(funcall + (compile + nil + '(lambda () + (let ((+max+ #xD800) + (base-char-ranges + #((#x0041 #x005A) (#x0061 #x007A) (#x00C0 #x00D6) (#x00D8 #x00F6) + (#x00F8 #x00FF) (#x0100 #x0131) (#x0134 #x013E) (#x0141 #x0148) + (#x014A #x017E) (#x0180 #x01C3) (#x01CD #x01F0) (#x01F4 #x01F5) + (#x01FA #x0217) (#x0250 #x02A8) (#x02BB #x02C1) (#x0386 #x0386) + (#x0388 #x038A) (#x038C #x038C) (#x038E #x03A1) (#x03A3 #x03CE) + (#x03D0 #x03D6) (#x03DA #x03DA) (#x03DC #x03DC) (#x03DE #x03DE) + (#x03E0 #x03E0) (#x03E2 #x03F3) (#x0401 #x040C) (#x040E #x044F) + (#x0451 #x045C) (#x045E #x0481) (#x0490 #x04C4) (#x04C7 #x04C8) + (#x04CB #x04CC) (#x04D0 #x04EB) (#x04EE #x04F5) (#x04F8 #x04F9) + (#x0531 #x0556) (#x0559 #x0559) (#x0561 #x0586) (#x05D0 #x05EA) + (#x05F0 #x05F2) (#x0621 #x063A) (#x0641 #x064A) (#x0671 #x06B7) + (#x06BA #x06BE) (#x06C0 #x06CE) (#x06D0 #x06D3) (#x06D5 #x06D5) + (#x06E5 #x06E6) (#x0905 #x0939) (#x093D #x093D) (#x0958 #x0961) + (#x0985 #x098C) (#x098F #x0990) (#x0993 #x09A8) (#x09AA #x09B0) + (#x09B2 #x09B2) (#x09B6 #x09B9) (#x09DC #x09DD) (#x09DF #x09E1) + (#x09F0 #x09F1) (#x0A05 #x0A0A) (#x0A0F #x0A10) (#x0A13 #x0A28) + (#x0A2A #x0A30) (#x0A32 #x0A33) (#x0A35 #x0A36) (#x0A38 #x0A39) + (#x0A59 #x0A5C) (#x0A5E #x0A5E) (#x0A72 #x0A74) (#x0A85 #x0A8B) + (#x0A8D #x0A8D) (#x0A8F #x0A91) (#x0A93 #x0AA8) (#x0AAA #x0AB0) + (#x0AB2 #x0AB3) (#x0AB5 #x0AB9) (#x0ABD #x0ABD) (#x0AE0 #x0AE0) + (#x0B05 #x0B0C) (#x0B0F #x0B10) (#x0B13 #x0B28) (#x0B2A #x0B30) + (#x0B32 #x0B33) (#x0B36 #x0B39) (#x0B3D #x0B3D) (#x0B5C #x0B5D) + (#x0B5F #x0B61) (#x0B85 #x0B8A) (#x0B8E #x0B90) (#x0B92 #x0B95) + (#x0B99 #x0B9A) (#x0B9C #x0B9C) (#x0B9E #x0B9F) (#x0BA3 #x0BA4) + (#x0BA8 #x0BAA) (#x0BAE #x0BB5) (#x0BB7 #x0BB9) (#x0C05 #x0C0C) + (#x0C0E #x0C10) (#x0C12 #x0C28) (#x0C2A #x0C33) (#x0C35 #x0C39) + (#x0C60 #x0C61) (#x0C85 #x0C8C) (#x0C8E #x0C90) (#x0C92 #x0CA8) + (#x0CAA #x0CB3) (#x0CB5 #x0CB9) (#x0CDE #x0CDE) (#x0CE0 #x0CE1) + (#x0D05 #x0D0C) (#x0D0E #x0D10) (#x0D12 #x0D28) (#x0D2A #x0D39) + (#x0D60 #x0D61) (#x0E01 #x0E2E) (#x0E30 #x0E30) (#x0E32 #x0E33) + (#x0E40 #x0E45) (#x0E81 #x0E82) (#x0E84 #x0E84) (#x0E87 #x0E88) + (#x0E8A #x0E8A) (#x0E8D #x0E8D) (#x0E94 #x0E97) (#x0E99 #x0E9F) + (#x0EA1 #x0EA3) (#x0EA5 #x0EA5) (#x0EA7 #x0EA7) (#x0EAA #x0EAB) + (#x0EAD #x0EAE) (#x0EB0 #x0EB0) (#x0EB2 #x0EB3) (#x0EBD #x0EBD) + (#x0EC0 #x0EC4) (#x0F40 #x0F47) (#x0F49 #x0F69) (#x10A0 #x10C5) + (#x10D0 #x10F6) (#x1100 #x1100) (#x1102 #x1103) (#x1105 #x1107) + (#x1109 #x1109) (#x110B #x110C) (#x110E #x1112) (#x113C #x113C) + (#x113E #x113E) (#x1140 #x1140) (#x114C #x114C) (#x114E #x114E) + (#x1150 #x1150) (#x1154 #x1155) (#x1159 #x1159) (#x115F #x1161) + (#x1163 #x1163) (#x1165 #x1165) (#x1167 #x1167) (#x1169 #x1169) + (#x116D #x116E) (#x1172 #x1173) (#x1175 #x1175) (#x119E #x119E) + (#x11A8 #x11A8) (#x11AB #x11AB) (#x11AE #x11AF) (#x11B7 #x11B8) + (#x11BA #x11BA) (#x11BC #x11C2) (#x11EB #x11EB) (#x11F0 #x11F0) + (#x11F9 #x11F9) (#x1E00 #x1E9B) (#x1EA0 #x1EF9) (#x1F00 #x1F15) + (#x1F18 #x1F1D) (#x1F20 #x1F45) (#x1F48 #x1F4D) (#x1F50 #x1F57) + (#x1F59 #x1F59) (#x1F5B #x1F5B) (#x1F5D #x1F5D) (#x1F5F #x1F7D) + (#x1F80 #x1FB4) (#x1FB6 #x1FBC) (#x1FBE #x1FBE) (#x1FC2 #x1FC4) + (#x1FC6 #x1FCC) (#x1FD0 #x1FD3) (#x1FD6 #x1FDB) (#x1FE0 #x1FEC) + (#x1FF2 #x1FF4) (#x1FF6 #x1FFC) (#x2126 #x2126) (#x212A #x212B) + (#x212E #x212E) (#x2180 #x2182) (#x3041 #x3094) (#x30A1 #x30FA) + (#x3105 #x312C) (#xAC00 #xD7A3))) + (ideographic-ranges #((#x3007 #x3007) (#x3021 #x3029)(#x4E00 #x9FA5))) + (combining-char-ranges + #((#x0300 #x0345) (#x0360 #x0361) (#x0483 #x0486) (#x0591 #x05A1) + (#x05A3 #x05B9) (#x05BB #x05BD) (#x05BF #x05BF) (#x05C1 #x05C2) + (#x05C4 #x05C4) (#x064B #x0652) (#x0670 #x0670) (#x06D6 #x06DC) + (#x06DD #x06DF) (#x06E0 #x06E4) (#x06E7 #x06E8) (#x06EA #x06ED) + (#x0901 #x0903) (#x093C #x093C) (#x093E #x094C) (#x094D #x094D) + (#x0951 #x0954) (#x0962 #x0963) (#x0981 #x0983) (#x09BC #x09BC) + (#x09BE #x09BE) (#x09BF #x09BF) (#x09C0 #x09C4) (#x09C7 #x09C8) + (#x09CB #x09CD) (#x09D7 #x09D7) (#x09E2 #x09E3) (#x0A02 #x0A02) + (#x0A3C #x0A3C) (#x0A3E #x0A3E) (#x0A3F #x0A3F) (#x0A40 #x0A42) + (#x0A47 #x0A48) (#x0A4B #x0A4D) (#x0A70 #x0A71) (#x0A81 #x0A83) + (#x0ABC #x0ABC) (#x0ABE #x0AC5) (#x0AC7 #x0AC9) (#x0ACB #x0ACD) + (#x0B01 #x0B03) (#x0B3C #x0B3C) (#x0B3E #x0B43) (#x0B47 #x0B48) + (#x0B4B #x0B4D) (#x0B56 #x0B57) (#x0B82 #x0B83) (#x0BBE #x0BC2) + (#x0BC6 #x0BC8) (#x0BCA #x0BCD) (#x0BD7 #x0BD7) (#x0C01 #x0C03) + (#x0C3E #x0C44) (#x0C46 #x0C48) (#x0C4A #x0C4D) (#x0C55 #x0C56) + (#x0C82 #x0C83) (#x0CBE #x0CC4) (#x0CC6 #x0CC8) (#x0CCA #x0CCD) + (#x0CD5 #x0CD6) (#x0D02 #x0D03) (#x0D3E #x0D43) (#x0D46 #x0D48) + (#x0D4A #x0D4D) (#x0D57 #x0D57) (#x0E31 #x0E31) (#x0E34 #x0E3A) + (#x0E47 #x0E4E) (#x0EB1 #x0EB1) (#x0EB4 #x0EB9) (#x0EBB #x0EBC) + (#x0EC8 #x0ECD) (#x0F18 #x0F19) (#x0F35 #x0F35) (#x0F37 #x0F37) + (#x0F39 #x0F39) (#x0F3E #x0F3E) (#x0F3F #x0F3F) (#x0F71 #x0F84) + (#x0F86 #x0F8B) (#x0F90 #x0F95) (#x0F97 #x0F97) (#x0F99 #x0FAD) + (#x0FB1 #x0FB7) (#x0FB9 #x0FB9) (#x20D0 #x20DC) (#x20E1 #x20E1) + (#x302A #x302F) (#x3099 #x3099) (#x309A #x309A)) + ) + (digit-ranges + #((#x0030 #x0039) (#x0660 #x0669) (#x06F0 #x06F9) (#x0966 #x096F) + (#x09E6 #x09EF) (#x0A66 #x0A6F) (#x0AE6 #x0AEF) (#x0B66 #x0B6F) + (#x0BE7 #x0BEF) (#x0C66 #x0C6F) (#x0CE6 #x0CEF) (#x0D66 #x0D6F) + (#x0E50 #x0E59) (#x0ED0 #x0ED9) (#x0F20 #x0F29))) + (extender-ranges + #((#x00B7 #x00B7) (#x02D0 #x02D0) (#x02D1 #x02D1) (#x0387 #x0387) + (#x0640 #x0640) (#x0E46 #x0E46) (#x0EC6 #x0EC6) (#x3005 #x3005) + (#x3031 #x3035) (#x309D #x309E) (#x30FC #x30FE)))) + (labels + ((rune-in-range-p (code range-vector) + (declare (type simple-vector range-vector)) + ;;we were always dealing with a sorted vector... bin search it + + (let ((start 0) + (end (length range-vector))) + (while (< start end) + (let ((mid-index (+ start (floor (- end start) 2)))) + (destructuring-bind (mid-item-low mid-item-high) + (aref range-vector mid-index) + (cond + ((< mid-item-high code) + (setf start (1+ mid-index))) + ((< code mid-item-low) + (setf end mid-index)) + (t + (return t)))))))) + + (name-start-rune-p (rune) + (or (letter-rune-p rune) + (= #.(char-code #\_) rune) + (= #.(char-code #\:) rune))) + + (name-rune-p (rune) + (or (letter-rune-p rune) + (digit-rune-p* rune) + (= rune #.(char-code #\.)) + (= rune #.(char-code #\-)) + (= rune #.(char-code #\_)) + (= rune #.(char-code #\:)) + (combining-rune-p rune) + (extender-rune-p rune))) + + (letter-rune-p (rune) + (or (base-rune-p rune) + (ideographic-rune-p rune))) + + (digit-rune-p* (rune) + (rune-in-range-p rune digit-ranges)) + + + (combining-rune-p (rune) + (rune-in-range-p rune combining-char-ranges)) + + (extender-rune-p (rune) + (rune-in-range-p rune extender-ranges)) + + (base-rune-p (rune) + (rune-in-range-p rune base-char-ranges)) + + (ideographic-rune-p (rune) + (rune-in-range-p rune ideographic-ranges)) + + + (predicate-to-bv (p) + (let ((r (make-array +max+ :element-type 'bit :initial-element 0))) + (dotimes (i +max+ r) + (when (funcall p i) + (setf (aref r i) 1))))) ) + + `(progn + (DEFINLINE NAME-RUNE-P (RUNE) + (SETF RUNE (RUNE-CODE RUNE)) + (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)) + (type fixnum rune)) + (AND (<= 0 RUNE ,+max+) + (= 1 (SBIT ',(predicate-to-bv #'name-rune-p) + RUNE))))) + (DEFINLINE NAME-START-RUNE-P (RUNE) + (SETF RUNE (RUNE-CODE RUNE)) + (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)) + (type fixnum rune)) + (AND (<= 0 RUNE ,+MAX+) + (= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p) + RUNE))))) + (definline valid-name-p (rod) + (and (plusp (length rod)) + (name-start-rune-p (elt rod 0)) + (every #'name-rune-p rod))) + (definline valid-nmtoken-p (rod) + (and (plusp (length rod)) + (every #'name-rune-p rod))))))))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xml-parse.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xml-parse.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xml-parse.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,3738 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CXML; readtable: runes; -*- +;;; --------------------------------------------------------------------------- +;;; Title: XML parser +;;; Created: 1999-07-17 +;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> +;;; Author: Henrik Motakef <hmot(a)henrik-motakef.de> +;;; Author: David Lichteblau <david(a)lichteblau.com> +;;; License: Lisp-LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1999 by Gilbert Baumann +;;; (c) copyright 2003 by Henrik Motakef +;;; (c) copyright 2004 knowledgeTools Int. GmbH +;;; (c) copyright 2004 David Lichteblau +;;; (c) copyright 2005 David Lichteblau + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 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 +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library 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. + +;;; Streams + +;;; xstreams + +;; For reading runes, I defined my own streams, called xstreams, +;; because we want to be fast. A function call or even a method call +;; per character is not acceptable, instead of that we define a +;; buffered stream with and advertised buffer layout, so that we +;; could use the trick stdio uses: READ-RUNE and PEEK-RUNE are macros, +;; directly accessing the buffer and only calling some underflow +;; handler in case of stream underflows. This will yield to quite a +;; performance boost vs calling READ-BYTE per character. + +;; Also we need to do encoding t conversion on ; this better done at large chunks of data rather than on a character +;; by character basis. This way we need a dispatch on the active +;; encoding only once in a while, instead of for each character. This +;; allows us to use a CLOS interface to do the underflow handling. + +;;; zstreams + +;; Now, for reading tokens, we define another kind of streams, called +;; zstreams. These zstreams also maintain an input stack to implement +;; inclusion of external entities. This input stack contains xstreams +;; or the special marker :STOP. Such a :STOP marker indicates, that +;; input should not continue there, but well stop; that is simulate an +;; EOF. The user is then responsible to pop this marker off the input +;; stack. +;; +;; This input stack is also used to detect circular entity inclusion. + +;; The zstream tokenizer recognizes the following types of tokens and +;; is controlled by the *DATA-BEHAVIOUR* flag. (Which should become a +;; slot of zstreams instead). + +;; Common +;; :xml-decl (<target> . <content>) ;processing-instruction starting with "<?xml" +;; :pi (<target> . <content>) ;processing-instruction +;; :stag (<name> . <atts>) ;start tag +;; :etag (<name> . <atts>) ;end tag +;; :ztag (<name> . <atts>) ;empty tag +;; :<!ELEMENT +;; :<!ENTITY +;; :<!ATTLIST +;; :<!NOTATION +;; :<!DOCTYPE +;; :<![ +;; :comment <content> + +;; *data-behaviour* = :DTD +;; +;; :nmtoken <interned-rod> +;; :#required +;; :#implied +;; :#fixed +;; :#pcdata +;; :s +;; :\[ :\] :$ :$ :|\ :\> :\" :\' :\, :\? :\* :\+ + +;; *data-behaviour* = :DOC +;; +;; :entity-ref <interned-rod> +;; :cdata <rod> + + +;;; TODO +;; +;; o provide for a faster DOM +;; +;; o morph zstream into a context object and thus also get rid of +;; special variables. Put the current DTD there too. +;; [partly done] + +;; o the *scratch-pad* hack should become something much more +;; reentrant, we could either define a system-wide resource +;; or allocate some scratch-pads per context. +;; [for thread-safety reasons the array are allocated per context now, +;; reentrancy is still open] + +;; o CR handling in utf-16 deocders +;; +;; o UCS-4 reader +;; +;; o max depth together with circle detection +;; (or proof, that our circle detection is enough). +;; [gemeint ist zstream-push--david] +;; +;; o better extensibility wrt character representation, one may want to +;; have +;; - UCS-4 in vectoren +;; +;; o xstreams auslagern, documententieren und dann auch in SGML und +;; CSS parser verwenden. (halt alles was zeichen liest). +;; [ausgelagert sind sie; dokumentiert "so la la"; die Reintegration +;; in Closure ist ein ganz anderes Thema] +;; +;; o recording of source locations for nodes. +;; +;; o based on the DTD and xml:space attribute implement HTML white +;; space rules. +;; +;; o on a parser option, do not expand external entities. + +;;;; Validity constraints: +;;;; (00) Root Element Type like (03), c.f. MAKE-ROOT-MODEL +;;;; (01) Proper Declaration/PE Nesting P/MARKUP-DECL +;;;; (02) Standalone Document Declaration all over the place [*] +;;;; (03) Element Valid VALIDATE-*-ELEMENT, -CHARACTERS +;;;; (04) Attribute Value Type VALIDATE-ATTRIBUTE +;;;; (05) Unique Element Type Declaration DEFINE-ELEMENT +;;;; (06) Proper Group/PE Nesting P/CSPEC +;;;; (07) No Duplicate Types LEGAL-CONTENT-MODEL-P +;;;; (08) ID VALIDATE-ATTRIBUTE +;;;; (09) One ID per Element Type DEFINE-ATTRIBUTE +;;;; (10) ID Attribute Default DEFINE-ATTRIBUTE +;;;; (11) IDREF VALIDATE-ATTRIBUTE, P/DOCUMENT +;;;; (12) Entity Name VALIDATE-ATTRIBUTE +;;;; (13) Name Token VALIDATE-ATTRIBUTE +;;;; (14) Notation Attributes VALIDATE-ATTRIBUTE, P/ATT-TYPE +;;;; (15) One Notation Per Element Type DEFINE-ATTRIBUTE +;;;; (16) No Notation on Empty Element DEFINE-ELEMENT, -ATTRIBUTE +;;;; (17) Enumeration VALIDATE-ATTRIBUTE +;;;; (18) Required Attribute PROCESS-ATTRIBUTES +;;;; (19) Attribute Default Legal DEFINE-ATTRIBUTE +;;;; (20) Fixed Attribute Default VALIDATE-ATTRIBUTE +;;;; (21) Proper Conditional Section/PE Nesting P/CONDITIONAL-SECT, ... +;;;; (22) Entity Declared [**] +;;;; (23) Notation Declared P/ENTITY-DEF, P/DOCUMENT +;;;; (24) Unique Notation Name DEFINE-NOTATION +;;;; +;;;; [*] Perhaps we could revert the explicit checks of (02), if we did +;;;; _not_ read external subsets of standalone documents when parsing in +;;;; validating mode. Violations of VC (02) constraints would then appear as +;;;; wellformedness violations, right? +;;;; +;;;; [**] Although I haven't investigated this properly yet, I believe that +;;;; we check this VC together with the WFC even in non-validating mode. + +(in-package :cxml) + +#+allegro +(setf (excl:named-readtable :runes) *readtable*) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *fast* '(optimize (speed 3) (safety 0))) + ;;(defparameter *fast* '(optimize (speed 2) (safety 3))) + ) + +;;; parser context + +(defvar *ctx* nil) + +(defstruct (context (:conc-name nil)) + handler + (dtd nil) + model-stack + ;; xml:base machen wir fuer klacks mal gleich als expliziten stack: + base-stack + (referenced-notations '()) + (id-table (%make-rod-hash-table)) + ;; FIXME: Wofuer ist name-hashtable da? Will man das wissen? + (name-hashtable (make-rod-hashtable :size 2000)) + (standalone-p nil) + (entity-resolver nil) + (disallow-internal-subset nil) + main-zstream) + +(defvar *expand-pe-p* nil) + +(defparameter *initial-namespace-bindings* + '((#"" . nil) + (#"xmlns" . #"http://www.w3.org/2000/xmlns/") + (#"xml" . #"http://www.w3.org/XML/1998/namespace"))) + +(defparameter *namespace-bindings* *initial-namespace-bindings*) + +;;;; --------------------------------------------------------------------------- +;;;; xstreams +;;;; + + +(defstruct (stream-name + (:print-function print-stream-name)) + entity-name + entity-kind + uri) + +(defun print-stream-name (object stream depth) + (declare (ignore depth)) + (format stream "[~A ~S ~A]" + (rod-string (stream-name-entity-name object)) + (stream-name-entity-kind object) + (stream-name-uri object))) + +(deftype read-element () 'rune) + +(defun call-with-open-xstream (fn stream) + (unwind-protect + (funcall fn stream) + (close-xstream stream))) + +(defmacro with-open-xstream ((var value) &body body) + `(call-with-open-xstream (lambda (,var) ,@body) ,value)) + +(defun call-with-open-xfile (continuation &rest open-args) + (let ((input (apply #'open (car open-args) :element-type '(unsigned-byte 8) (cdr open-args)))) + (unwind-protect + (progn + (funcall continuation (make-xstream input))) + (close input)))) + +(defmacro with-open-xfile ((stream &rest open-args) &body body) + `(call-with-open-xfile (lambda (,stream) .,body) .,open-args)) + +;;;; ------------------------------------------------------------------- +;;;; Rechnen mit Runen +;;;; + +;; Let us first define fast fixnum arithmetric get rid of type +;; checks. (After all we know what we do here). + +(defmacro fx-op (op &rest xs) + `(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))) +(defmacro fx-pred (op &rest xs) + `(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))) + +(defmacro %+ (&rest xs) `(fx-op + ,@xs)) +(defmacro %- (&rest xs) `(fx-op - ,@xs)) +(defmacro %* (&rest xs) `(fx-op * ,@xs)) +(defmacro %/ (&rest xs) `(fx-op floor ,@xs)) +(defmacro %and (&rest xs) `(fx-op logand ,@xs)) +(defmacro %ior (&rest xs) `(fx-op logior ,@xs)) +(defmacro %xor (&rest xs) `(fx-op logxor ,@xs)) +(defmacro %ash (&rest xs) `(fx-op ash ,@xs)) +(defmacro %mod (&rest xs) `(fx-op mod ,@xs)) + +(defmacro %= (&rest xs) `(fx-pred = ,@xs)) +(defmacro %<= (&rest xs) `(fx-pred <= ,@xs)) +(defmacro %>= (&rest xs) `(fx-pred >= ,@xs)) +(defmacro %< (&rest xs) `(fx-pred < ,@xs)) +(defmacro %> (&rest xs) `(fx-pred > ,@xs)) + +;;; XXX Geschwindigkeit dieser Definitionen untersuchen! + +(defmacro rune-op (op &rest xs) + `(code-rune (,op ,@(mapcar (lambda (x) `(rune-code ,x)) xs)))) +(defmacro rune-pred (op &rest xs) + `(,op ,@(mapcar (lambda (x) `(rune-code ,x)) xs))) + +(defmacro %rune+ (&rest xs) `(rune-op + ,@xs)) +(defmacro %rune- (&rest xs) `(rune-op - ,@xs)) +(defmacro %rune* (&rest xs) `(rune-op * ,@xs)) +(defmacro %rune/ (&rest xs) `(rune-op floor ,@xs)) +(defmacro %rune-and (&rest xs) `(rune-op logand ,@xs)) +(defmacro %rune-ior (&rest xs) `(rune-op logior ,@xs)) +(defmacro %rune-xor (&rest xs) `(rune-op logxor ,@xs)) +(defmacro %rune-ash (a b) `(code-rune (ash (rune-code ,a) ,b))) +(defmacro %rune-mod (&rest xs) `(rune-op mod ,@xs)) + +(defmacro %rune= (&rest xs) `(rune-pred = ,@xs)) +(defmacro %rune<= (&rest xs) `(rune-pred <= ,@xs)) +(defmacro %rune>= (&rest xs) `(rune-pred >= ,@xs)) +(defmacro %rune< (&rest xs) `(rune-pred < ,@xs)) +(defmacro %rune> (&rest xs) `(rune-pred > ,@xs)) + +;;;; --------------------------------------------------------------------------- +;;;; rod hashtable +;;;; + +;;; make-rod-hashtable +;;; rod-hash-get hashtable rod &optional start end -> value ; successp +;;; (setf (rod-hash-get hashtable rod &optional start end) new-value +;;; + +(defstruct (rod-hashtable (:constructor make-rod-hashtable/low)) + size ;size of table + table ; + ) + +(defun make-rod-hashtable (&key (size 200)) + (setf size (nearest-greater-prime size)) + (make-rod-hashtable/low + :size size + :table (make-array size :initial-element nil))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +fixnum-bits+ + (1- (integer-length most-positive-fixnum)) + "Pessimistic approximation of the number of bits of fixnums.") + + (defconstant +fixnum-mask+ + (1- (expt 2 +fixnum-bits+)) + "Pessimistic approximation of the largest bit-mask, still being a fixnum.")) + +(definline stir (a b) + (%and +fixnum-mask+ + (%xor (%ior (%ash (%and a #.(ash +fixnum-mask+ -5)) 5) + (%ash a #.(- 5 +fixnum-bits+))) + b))) + +(definline rod-hash (rod start end) + "Compute a hash code out of a rod." + (let ((res (%- end start))) + (do ((i start (%+ i 1))) + ((%= i end)) + (declare (type fixnum i)) + (setf res (stir res (rune-code (%rune rod i))))) + res)) + +(definline rod=* (x y &key (start1 0) (end1 (length x)) + (start2 0) (end2 (length y))) + (and (%= (%- end1 start1) (%- end2 start2)) + (do ((i start1 (%+ i 1)) + (j start2 (%+ j 1))) + ((%= i end1) + t) + (unless (rune= (%rune x i) (%rune y j)) + (return nil))))) + +(definline rod=** (x y start1 end1 start2 end2) + (and (%= (%- end1 start1) (%- end2 start2)) + (do ((i start1 (%+ i 1)) + (j start2 (%+ j 1))) + ((%= i end1) + t) + (unless (rune= (%rune x i) (%rune y j)) + (return nil))))) + +(defun rod-hash-get (hashtable rod &optional (start 0) (end (length rod))) + (declare (type (simple-array rune (*)) rod)) + (let ((j (%mod (rod-hash rod start end) + (rod-hashtable-size hashtable)))) + (dolist (q (svref (rod-hashtable-table hashtable) j) + (values nil nil nil)) + (declare (type cons q)) + (when (rod=** (car q) rod 0 (length (the (simple-array rune (*)) (car q))) start end) + (return (values (cdr q) t (car q))))))) + +(defun rod-hash-set (new-value hashtable rod &optional (start 0) (end (length rod))) + (let ((j (%mod (rod-hash rod start end) + (rod-hashtable-size hashtable))) + (key nil)) + (dolist (q (svref (rod-hashtable-table hashtable) j) + (progn + (setf key (rod-subseq* rod start end)) + (push (cons key new-value) + (aref (rod-hashtable-table hashtable) j)))) + (when (rod=* (car q) rod :start2 start :end2 end) + (setf key (car q)) + (setf (cdr q) new-value) + (return))) + (values new-value key))) + +#-rune-is-character +(defun rod-subseq* (source start &optional (end (length source))) + (unless (and (typep start 'fixnum) (>= start 0)) + (error "~S is not a non-negative fixnum." start)) + (unless (and (typep end 'fixnum) (>= end start)) + (error "END argument, ~S, is not a fixnum no less than START, ~S." end start)) + (when (> start (length source)) + (error "START argument, ~S, should be no greater than length of rod." start)) + (when (> end (length source)) + (error "END argument, ~S, should be no greater than length of rod." end)) + (locally + (declare (type fixnum start end)) + (let ((res (make-rod (- end start)))) + (declare (type rod res)) + (do ((i (- (- end start) 1) (the fixnum (- i 1)))) + ((< i 0) res) + (declare (type fixnum i)) + (setf (%rune res i) (aref source (the fixnum (+ i start)))))))) + +#+rune-is-character +(defun rod-subseq* (source start &optional (end (length source))) + (subseq source start end)) + +(deftype ufixnum () `(unsigned-byte ,(integer-length most-positive-fixnum))) + +#-rune-is-character +(defun rod-subseq** (source start &optional (end (length source))) + (declare (type (simple-array rune (*)) source) + (type ufixnum start) + (type ufixnum end) + (optimize (speed 3) (safety 0))) + (let ((res (make-array (%- end start) :element-type 'rune))) + (declare (type (simple-array rune (*)) res)) + (let ((i (%- end start))) + (declare (type ufixnum i)) + (loop + (setf i (- i 1)) + (when (= i 0) + (return)) + (setf (%rune res i) (%rune source (the ufixnum (+ i start)))))) + res)) + +#+rune-is-character +(defun rod-subseq** (source start &optional (end (length source))) + (subseq source start end)) + +(defun (setf rod-hash-get) (new-value hashtable rod &optional (start 0) (end (length rod))) + (rod-hash-set new-value hashtable rod start end)) + +(defun intern-name (rod &optional (start 0) (end (length rod))) + (multiple-value-bind (value successp key) (rod-hash-get (name-hashtable *ctx*) rod start end) + (declare (ignore value)) + (if successp + key + (nth-value 1 (rod-hash-set t (name-hashtable *ctx*) rod start end))))) + +;;;; --------------------------------------------------------------------------- +;;;; +;;;; rod collector +;;;; + +(defvar *scratch-pad*) +(defvar *scratch-pad-2*) +(defvar *scratch-pad-3*) +(defvar *scratch-pad-4*) + +(declaim (type (simple-array rune (*)) + *scratch-pad* *scratch-pad-2* *scratch-pad-3* *scratch-pad-4*)) + +(defmacro with-scratch-pads ((&optional) &body body) + `(let ((*scratch-pad* (make-array 1024 :element-type 'rune)) + (*scratch-pad-2* (make-array 1024 :element-type 'rune)) + (*scratch-pad-3* (make-array 1024 :element-type 'rune)) + (*scratch-pad-4* (make-array 1024 :element-type 'rune))) + ,@body)) + +(defmacro %put-unicode-char (code-var put) + `(progn + (cond ((%> ,code-var #xFFFF) + (,put (the rune (code-rune (%+ #xD7C0 (%ash ,code-var -10))))) + (,put (the rune (code-rune (%ior #xDC00 (%and ,code-var #x03FF)))))) + (t + (,put (code-rune ,code-var)))))) + +(defun adjust-array-by-copying (old-array new-size) + "Adjust an array by copying and thus ensures, that result is a SIMPLE-ARRAY." + (let ((res (make-array new-size :element-type (array-element-type old-array)))) + (replace res old-array + :start1 0 :end1 (length old-array) + :start2 0 :end2 (length old-array)) + res)) + +(defmacro with-rune-collector-aux (scratch collect body mode) + (let ((rod (gensym)) + (n (gensym)) + (i (gensym)) + (b (gensym))) + `(let ((,n (length ,scratch)) + (,i 0) + (,b ,scratch)) + (declare (type fixnum ,n ,i)) + (macrolet + ((,collect (x) + `((lambda (x) + (locally + (declare #.*fast*) + (when (%>= ,',i ,',n) + (setf ,',n (* 2 ,',n)) + (setf ,',b + (setf ,',scratch + (adjust-array-by-copying ,',scratch ,',n)))) + (setf (aref (the (simple-array rune (*)) ,',b) ,',i) x) + (incf ,',i))) + ,x))) + ,@body + ,(ecase mode + (:intern + `(intern-name ,b 0 ,i)) + (:copy + `(let ((,rod (make-rod ,i))) + (while (not (%= ,i 0)) + (setf ,i (%- ,i 1)) + (setf (%rune ,rod ,i) + (aref (the (simple-array rune (*)) ,b) ,i))) + ,rod)) + (:raw + `(values ,b 0 ,i)) + ))))) + +'(defmacro with-rune-collector-aux (scratch collect body mode) + (let ((rod (gensym)) + (n (gensym)) + (i (gensym)) + (b (gensym))) + `(let ((,n (length ,scratch)) + (,i 0)) + (declare (type fixnum ,n ,i)) + (macrolet + ((,collect (x) + `((lambda (x) + (locally + (declare #.*fast*) + (when (%>= ,',i ,',n) + (setf ,',n (* 2 ,',n)) + (setf ,',scratch + (setf ,',scratch + (adjust-array-by-copying ,',scratch ,',n)))) + (setf (aref (the (simple-array rune (*)) ,',scratch) ,',i) x) + (incf ,',i))) + ,x))) + ,@body + ,(ecase mode + (:intern + `(intern-name ,scratch 0 ,i)) + (:copy + `(let ((,rod (make-rod ,i))) + (while (%> ,i 0) + (setf ,i (%- ,i 1)) + (setf (%rune ,rod ,i) + (aref (the (simple-array rune (*)) ,scratch) ,i))) + ,rod)) + (:raw + `(values ,scratch 0 ,i)) + ))))) + +(defmacro with-rune-collector ((collect) &body body) + `(with-rune-collector-aux *scratch-pad* ,collect ,body :copy)) + +(defmacro with-rune-collector-2 ((collect) &body body) + `(with-rune-collector-aux *scratch-pad-2* ,collect ,body :copy)) + +(defmacro with-rune-collector-3 ((collect) &body body) + `(with-rune-collector-aux *scratch-pad-3* ,collect ,body :copy)) + +(defmacro with-rune-collector-4 ((collect) &body body) + `(with-rune-collector-aux *scratch-pad-4* ,collect ,body :copy)) + +(defmacro with-rune-collector/intern ((collect) &body body) + `(with-rune-collector-aux *scratch-pad* ,collect ,body :intern)) + +(defmacro with-rune-collector/raw ((collect) &body body) + `(with-rune-collector-aux *scratch-pad* ,collect ,body :raw)) + +#| +(defmacro while-reading-runes ((reader stream-in) &rest body) + ;; Thou shalt not leave body via a non local exit + (let ((stream (make-symbol "STREAM")) + (rptr (make-symbol "RPTR")) + (fptr (make-symbol "FPTR")) + (buf (make-symbol "BUF")) ) + `(let* ((,stream ,stream-in) + (,rptr (xstream-read-ptr ,stream)) + (,fptr (xstream-fill-ptr ,stream)) + (,buf (xstream-buffer ,stream))) + (declare (type fixnum ,rptr ,fptr) + (type xstream ,stream)) + (macrolet ((,reader (res-var) + `(cond ((%= ,',rptr ,',fptr) + (setf (xstream-read-ptr ,',stream) ,',rptr) + (setf ,res-var (xstream-underflow ,',stream)) + (setf ,',rptr (xstream-read-ptr ,',stream)) + (setf ,',fptr (xstream-fill-ptr ,',stream)) + (setf ,',buf (xstream-buffer ,',stream))) + (t + (setf ,res-var + (aref (the (simple-array read-element (*)) ,',buf) + (the fixnum ,',rptr))) + (setf ,',rptr (%+ ,',rptr 1)))))) + (prog1 + (let () .,body) + (setf (xstream-read-ptr ,stream) ,rptr) ))))) +|# + +;;;; --------------------------------------------------------------------------- +;;;; DTD +;;;; + +(define-condition xml-parse-error (simple-error) ()) +(define-condition well-formedness-violation (xml-parse-error) ()) +(define-condition validity-error (xml-parse-error) ()) + +;; We make some effort to signal end of file as a special condition, but we +;; don't actually try very hard. Not sure whether we should. Right now I +;; would prefer not to document this class. +(define-condition end-of-xstream (well-formedness-violation) ()) + +(defun describe-xstream (x s) + (format s " Line ~D, column ~D in ~A~%" + (xstream-line-number x) + (xstream-column-number x) + (let ((name (xstream-name x))) + (cond + ((null name) + "<anonymous stream>") + ((eq :main (stream-name-entity-kind name)) + (stream-name-uri name)) + (t + name))))) + +(defun %error (class stream message) + (let* ((zmain (if *ctx* (main-zstream *ctx*) nil)) + (zstream (if (zstream-p stream) stream zmain)) + (xstream (if (xstream-p stream) stream nil)) + (s (make-string-output-stream))) + (write-line message s) + (when xstream + (write-line "Location:" s) + (describe-xstream xstream s)) + (when zstream + (let ((stack + (remove xstream (remove :stop (zstream-input-stack zstream))))) + (when stack + (write-line "Context:" s) + (dolist (x stack) + (describe-xstream x s))))) + (when (and zmain (not (eq zstream zmain))) + (let ((stack + (remove xstream (remove :stop (zstream-input-stack zmain))))) + (when stack + (write-line "Context in main document:" s) + (dolist (x stack) + (describe-xstream x s))))) + (error class + :format-control "~A" + :format-arguments (list (get-output-stream-string s))))) + +(defun validity-error (fmt &rest args) + (%error 'validity-error + nil + (format nil "Document not valid: ~?" fmt args))) + +(defun wf-error (stream fmt &rest args) + (%error 'well-formedness-violation + stream + (format nil "Document not well-formed: ~?" fmt args))) + +(defun eox (stream &optional x &rest args) + (%error 'end-of-xstream + stream + (format nil "End of file~@[: ~?~]" x args))) + +(defclass cxml-parser (sax:sax-parser) ((ctx :initarg :ctx))) + +(defun parser-xstream (parser) + (car (zstream-input-stack (main-zstream (slot-value parser 'ctx))))) + +(defun parser-stream-name (parser) + (let ((xstream (parser-xstream parser))) + (if xstream + (xstream-name xstream) + nil))) + +(defmethod sax:line-number ((parser cxml-parser)) + (let ((x (parser-xstream parser))) + (if x + (xstream-line-number x) + nil))) + +(defmethod sax:column-number ((parser cxml-parser)) + (let ((x (parser-xstream parser))) + (if x + (xstream-column-number x) + nil))) + +(defmethod sax:system-id ((parser cxml-parser)) + (let ((name (parser-stream-name parser))) + (if name + (stream-name-uri name) + nil))) + +(defmethod sax:xml-base ((parser cxml-parser)) + (car (base-stack (slot-value parser 'ctx)))) + +(defvar *validate* t) +(defvar *external-subset-p* nil) + +(defun validate-start-element (ctx name) + (when *validate* + (let* ((pair (car (model-stack ctx))) + (newval (funcall (car pair) name))) + (unless newval + (validity-error "(03) Element Valid: ~A" (rod-string name))) + (setf (car pair) newval) + (let ((e (find-element name (dtd ctx)))) + (unless e + (validity-error "(03) Element Valid: no definition for ~A" + (rod-string name))) + (maybe-compile-cspec e) + (push (copy-cons (elmdef-compiled-cspec e)) (model-stack ctx)))))) + +(defun copy-cons (x) + (cons (car x) (cdr x))) + +(defun validate-end-element (ctx name) + (when *validate* + (let ((pair (car (model-stack ctx)))) + (unless (eq (funcall (car pair) nil) t) + (validity-error "(03) Element Valid: ~A" (rod-string name))) + (pop (model-stack ctx))))) + +(defun validate-characters (ctx rod) + (when *validate* + (let ((pair (car (model-stack ctx)))) + (unless (funcall (cdr pair) rod) + (validity-error "(03) Element Valid: unexpected PCDATA"))))) + +(defun standalone-check-necessary-p (def) + (and *validate* + (standalone-p *ctx*) + (etypecase def + (elmdef (elmdef-external-p def)) + (attdef (attdef-external-p def))))) + +;; attribute validation, defaulting, and normalization -- except for for +;; uniqueness checks, which are done after namespaces have been declared +(defun process-attributes (ctx name attlist) + (let ((e (find-element name (dtd ctx)))) + (cond + (e + (dolist (ad (elmdef-attributes e)) ;handle default values + (unless (get-attribute (attdef-name ad) attlist) + (case (attdef-default ad) + (:IMPLIED) + (:REQUIRED + (when *validate* + (validity-error "(18) Required Attribute: ~S not specified" + (rod-string (attdef-name ad))))) + (t + (when (standalone-check-necessary-p ad) + (validity-error "(02) Standalone Document Declaration: missing attribute value")) + (push (sax:make-attribute :qname (attdef-name ad) + :value (cadr (attdef-default ad)) + :specified-p nil) + attlist))))) + (dolist (a attlist) ;normalize non-CDATA values + (let* ((qname (sax:attribute-qname a)) + (adef (find-attribute e qname))) + (when adef + (when (and *validate* + sax:*namespace-processing* + (eq (attdef-type adef) :ID) + (find #/: (sax:attribute-value a))) + (validity-error "colon in ID attribute")) + (unless (eq (attdef-type adef) :CDATA) + (let ((canon (canon-not-cdata-attval (sax:attribute-value a)))) + (when (and (standalone-check-necessary-p adef) + (not (rod= (sax:attribute-value a) canon))) + (validity-error "(02) Standalone Document Declaration: attribute value not normalized")) + (setf (sax:attribute-value a) canon)))))) + (when *validate* ;maybe validate attribute values + (dolist (a attlist) + (validate-attribute ctx e a)))) + ((and *validate* attlist) + (validity-error "(04) Attribute Value Type: no definition for element ~A" + (rod-string name))))) + attlist) + +(defun get-attribute (name attributes) + (member name attributes :key #'sax:attribute-qname :test #'rod=)) + +(defun validate-attribute (ctx e a) + (when (sax:attribute-specified-p a) ;defaults checked by DEFINE-ATTRIBUTE + (let* ((qname (sax:attribute-qname a)) + (adef + (or (find-attribute e qname) + (validity-error "(04) Attribute Value Type: not declared: ~A" + (rod-string qname))))) + (validate-attribute* ctx adef (sax:attribute-value a))))) + +(defun validate-attribute* (ctx adef value) + (let ((type (attdef-type adef)) + (default (attdef-default adef))) + (when (and (listp default) + (eq (car default) :FIXED) + (not (rod= value (cadr default)))) + (validity-error "(20) Fixed Attribute Default: expected ~S but got ~S" + (rod-string (cadr default)) + (rod-string value))) + (ecase (if (listp type) (car type) type) + (:ID + (unless (valid-name-p value) + (validity-error "(08) ID: not a name: ~S" (rod-string value))) + (when (eq (gethash value (id-table ctx)) t) + (validity-error "(08) ID: ~S not unique" (rod-string value))) + (setf (gethash value (id-table ctx)) t)) + (:IDREF + (validate-idref ctx value)) + (:IDREFS + (let ((names (split-names value))) + (unless names + (validity-error "(11) IDREF: malformed names")) + (mapc (curry #'validate-idref ctx) names))) + (:NMTOKEN + (validate-nmtoken value)) + (:NMTOKENS + (let ((tokens (split-names value))) + (unless tokens + (validity-error "(13) Name Token: malformed NMTOKENS")) + (mapc #'validate-nmtoken tokens))) + (:ENUMERATION + (unless (member value (cdr type) :test #'rod=) + (validity-error "(17) Enumeration: value not declared: ~S" + (rod-string value)))) + (:NOTATION + (unless (member value (cdr type) :test #'rod=) + (validity-error "(14) Notation Attributes: ~S" (rod-string value)))) + (:ENTITY + (validate-entity value)) + (:ENTITIES + (let ((names (split-names value))) + (unless names + (validity-error "(13) Name Token: malformed NMTOKENS")) + (mapc #'validate-entity names))) + (:CDATA)))) + +(defun validate-idref (ctx value) + (unless (valid-name-p value) + (validity-error "(11) IDREF: not a name: ~S" (rod-string value))) + (unless (gethash value (id-table ctx)) + (setf (gethash value (id-table ctx)) nil))) + +(defun validate-nmtoken (value) + (unless (valid-nmtoken-p value) + (validity-error "(13) Name Token: not a NMTOKEN: ~S" + (rod-string value)))) + +(defstruct (entdef (:constructor))) + +(defstruct (internal-entdef + (:include entdef) + (:constructor make-internal-entdef (value)) + (:conc-name #:entdef-)) + (value (error "missing argument") :type rod) + (expansion nil) + (external-subset-p *external-subset-p*)) + +(defstruct (external-entdef + (:include entdef) + (:constructor make-external-entdef (extid ndata)) + (:conc-name #:entdef-)) + (extid (error "missing argument") :type extid) + (ndata nil :type (or rod null))) + +(defun validate-entity (value) + (unless (valid-name-p value) + (validity-error "(12) Entity Name: not a name: ~S" (rod-string value))) + (let ((def (let ((*validate* + ;; Similarly the entity refs are internal and + ;; don't need normalization ... the unparsed + ;; entities (and entities) aren't "references" + ;; -- sun/valid/sa03.xml + nil)) + (get-entity-definition value :general (dtd *ctx*))))) + (unless (and (typep def 'external-entdef) (entdef-ndata def)) + ;; unparsed entity + (validity-error "(12) Entity Name: ~S" (rod-string value))))) + +(defun split-names (rod) + (flet ((whitespacep (x) + (or (rune= x #/U+0009) + (rune= x #/U+000A) + (rune= x #/U+000D) + (rune= x #/U+0020)))) + (if (let ((n (length rod))) + (and (not (zerop n)) + (or (whitespacep (rune rod 0)) + (whitespacep (rune rod (1- n)))))) + nil + (split-sequence-if #'whitespacep rod :remove-empty-subseqs t)))) + +(defun zstream-base-sysid (zstream) + (let ((base-sysid + (dolist (k (zstream-input-stack zstream)) + (let ((base-sysid (stream-name-uri (xstream-name k)))) + (when base-sysid (return base-sysid)))))) + base-sysid)) + +(defun absolute-uri (sysid source-stream) + (let ((base-sysid (zstream-base-sysid source-stream))) + ;; XXX is the IF correct? + (if base-sysid + (puri:merge-uris sysid base-sysid) + sysid))) + +(defstruct (extid (:constructor make-extid (public system))) + (public nil :type (or rod null)) + (system (error "missing argument") :type (or puri:uri null))) + +(defun absolute-extid (source-stream extid) + (let ((sysid (extid-system extid)) + (result (copy-extid extid))) + (setf (extid-system result) (absolute-uri sysid source-stream)) + result)) + +(defun define-entity (source-stream name kind def) + (setf name (intern-name name)) + (when (and sax:*namespace-processing* (find #/: name)) + (wf-error source-stream "colon in entity name")) + (let ((table + (ecase kind + (:general (dtd-gentities (dtd *ctx*))) + (:parameter (dtd-pentities (dtd *ctx*)))))) + (unless (gethash name table) + (when (and source-stream (handler *ctx*)) + (report-entity (handler *ctx*) kind name def)) + (when (typep def 'external-entdef) + (setf (entdef-extid def) + (absolute-extid source-stream (entdef-extid def)))) + (setf (gethash name table) + (cons *external-subset-p* def))))) + +(defun get-entity-definition (entity-name kind dtd) + (unless dtd + (wf-error nil "entity not defined: ~A" (rod-string entity-name))) + (destructuring-bind (extp &rest def) + (gethash entity-name + (ecase kind + (:general (dtd-gentities dtd)) + (:parameter (dtd-pentities dtd))) + '(nil)) + (when (and *validate* (standalone-p *ctx*) extp) + (validity-error "(02) Standalone Document Declaration: entity reference: ~S" + (rod-string entity-name))) + def)) + +(defun entity->xstream (zstream entity-name kind &optional internalp) + ;; `zstream' is for error messages + (let ((def (get-entity-definition entity-name kind (dtd *ctx*)))) + (unless def + (wf-error zstream "Entity '~A' is not defined." (rod-string entity-name))) + (let (r) + (etypecase def + (internal-entdef + (when (and (standalone-p *ctx*) + (entdef-external-subset-p def)) + (wf-error + zstream + "entity declared in external subset, but document is standalone")) + (setf r (make-rod-xstream (entdef-value def))) + (setf (xstream-name r) + (make-stream-name :entity-name entity-name + :entity-kind kind + :uri nil))) + (external-entdef + (when internalp + (wf-error zstream + "entity not internal: ~A" (rod-string entity-name))) + (when (entdef-ndata def) + (wf-error zstream + "reference to unparsed entity: ~A" + (rod-string entity-name))) + (setf r (xstream-open-extid (extid-using-catalog (entdef-extid def)))) + (setf (stream-name-entity-name (xstream-name r)) entity-name + (stream-name-entity-kind (xstream-name r)) kind))) + r))) + +(defun checked-get-entdef (name type) + (let ((def (get-entity-definition name type (dtd *ctx*)))) + (unless def + (wf-error nil "Entity '~A' is not defined." (rod-string name))) + def)) + +(defun xstream-open-extid* (entity-resolver pubid sysid) + (let* ((stream + (or (funcall (or entity-resolver (constantly nil)) pubid sysid) + (open (uri-to-pathname sysid) + :element-type '(unsigned-byte 8) + :direction :input)))) + (make-xstream stream + :name (make-stream-name :uri sysid) + :initial-speed 1))) + +(defun xstream-open-extid (extid) + (xstream-open-extid* (entity-resolver *ctx*) + (extid-public extid) + (extid-system extid))) + +(defun call-with-entity-expansion-as-stream (zstream cont name kind internalp) + ;; `zstream' is for error messages + (let ((in (entity->xstream zstream name kind internalp))) + (push (stream-name-uri (xstream-name in)) (base-stack *ctx*)) + (unwind-protect + (funcall cont in) + (pop (base-stack *ctx*)) + (close-xstream in)))) + +(defun ensure-dtd () + (unless (dtd *ctx*) + (setf (dtd *ctx*) (make-dtd)) + (define-default-entities))) + +(defun define-default-entities () + (define-entity nil #"lt" :general (make-internal-entdef #"<")) + (define-entity nil #"gt" :general (make-internal-entdef #">")) + (define-entity nil #"amp" :general (make-internal-entdef #"&")) + (define-entity nil #"apos" :general (make-internal-entdef #"'")) + (define-entity nil #"quot" :general (make-internal-entdef #"\""))) + +(defstruct attdef + ;; an attribute definition + element ;name of element this attribute belongs to + name ;name of attribute + type ;type of attribute; either one of :CDATA, :ID, :IDREF, :IDREFS, + ; :ENTITY, :ENTITIES, :NMTOKEN, :NMTOKENS, or + ; (:NOTATION <name>*) + ; (:ENUMERATION <name>*) + default ;default value of attribute: + ; :REQUIRED, :IMPLIED, (:FIXED content) or (:DEFAULT content) + (external-p *external-subset-p*) + ) + +(defstruct elmdef + ;; an element definition + name ;name of the element + content ;content model [*] + attributes ;list of defined attributes + compiled-cspec ;cons of validation function for contentspec + (external-p *external-subset-p*) + ) + +;; [*] in XML it is possible to define attributes before the element +;; itself is defined and since we hang attribute definitions into the +;; relevant element definitions, the `content' slot indicates whether an +;; element was actually defined. It is NIL until set to a content model +;; when the element type declaration is processed. + +(defun %make-rod-hash-table () + ;; XXX with portable hash tables, this is the only way to case-sensitively + ;; use rods. However, EQUALP often has horrible performance! Most Lisps + ;; provide extensions for user-defined equality, we should use them! There + ;; is also a home-made hash table for rods defined below, written by + ;; Gilbert (I think). We could also use that one, but I would prefer the + ;; first method, even if it's unportable. + (make-hash-table :test + #+rune-is-character 'equal + #-rune-is-character 'equalp)) + +(defstruct dtd + (elements (%make-rod-hash-table)) ;elmdefs + (gentities (%make-rod-hash-table)) ;general entities + (pentities (%make-rod-hash-table)) ;parameter entities + (notations (%make-rod-hash-table))) + +(defun make-dtd-cache () + (puri:make-uri-space)) + +(defvar *cache-all-dtds* nil) +(defvar *dtd-cache* (make-dtd-cache)) + +(defun remdtd (uri dtd-cache) + (setf uri (puri:intern-uri uri dtd-cache)) + (prog1 + (and (getf (puri:uri-plist uri) 'dtd) t) + (puri:unintern-uri uri dtd-cache))) + +(defun clear-dtd-cache (dtd-cache) + (puri:unintern-uri t dtd-cache)) + +(defun getdtd (uri dtd-cache) + (getf (puri:uri-plist (puri:intern-uri uri dtd-cache)) 'dtd)) + +(defun (setf getdtd) (newval uri dtd-cache) + (setf (getf (puri:uri-plist (puri:intern-uri uri dtd-cache)) 'dtd) newval) + newval) + + +;;;; + +(defun find-element (name dtd) + (gethash name (dtd-elements dtd))) + +(defun define-element (dtd element-name &optional content-model) + (let ((e (find-element element-name dtd))) + (cond + ((null e) + (prog1 + (setf (gethash element-name (dtd-elements dtd)) + (make-elmdef :name element-name :content content-model)) + (sax:element-declaration (handler *ctx*) element-name content-model))) + ((null content-model) + e) + (t + (when *validate* + (when (elmdef-content e) + (validity-error "(05) Unique Element Type Declaration")) + (when (eq content-model :EMPTY) + (dolist (ad (elmdef-attributes e)) + (let ((type (attdef-type ad))) + (when (and (listp type) (eq (car type) :NOTATION)) + (validity-error "(16) No Notation on Empty Element: ~S" + (rod-string element-name))))))) + (sax:element-declaration (handler *ctx*) element-name content-model) + (setf (elmdef-content e) content-model) + (setf (elmdef-external-p e) *external-subset-p*) + e)))) + +(defvar *redefinition-warning* nil) + +(defun define-attribute (dtd element name type default) + (let ((adef (make-attdef :element element + :name name + :type type + :default default)) + (e (or (find-element element dtd) + (define-element dtd element)))) + (when (and *validate* (listp default)) + (unless (eq (attdef-type adef) :CDATA) + (setf (second default) (canon-not-cdata-attval (second default)))) + (validate-attribute* *ctx* adef (second default))) + (cond ((find-attribute e name) + (when *redefinition-warning* + (warn "Attribute \"~A\" of \"~A\" not redefined." + (rod-string name) + (rod-string element)))) + (t + (when *validate* + (when (eq type :ID) + (when (find :ID (elmdef-attributes e) :key #'attdef-type) + (validity-error "(09) One ID per Element Type: element ~A" + (rod-string element))) + (unless (member default '(:REQUIRED :IMPLIED)) + (validity-error "(10) ID Attribute Default: ~A" + (rod-string element)))) + (flet ((notationp (type) + (and (listp type) (eq (car type) :NOTATION)))) + (when (notationp type) + (when (find-if #'notationp (elmdef-attributes e) + :key #'attdef-type) + (validity-error "(15) One Notation Per Element Type: ~S" + (rod-string element))) + (when (eq (elmdef-content e) :EMPTY) + (validity-error "(16) No Notation on Empty Element: ~S" + (rod-string element)))))) + (sax:attribute-declaration (handler *ctx*) element name type default) + (push adef (elmdef-attributes e)))))) + +(defun find-attribute (elmdef name) + (find name (elmdef-attributes elmdef) :key #'attdef-name :test #'rod=)) + +(defun define-notation (dtd name id) + (let ((ns (dtd-notations dtd))) + (when (gethash name ns) + (validity-error "(24) Unique Notation Name: ~S" (rod-string name))) + (setf (gethash name ns) id))) + +(defun find-notation (name dtd) + (gethash name (dtd-notations dtd))) + +;;;; --------------------------------------------------------------------------- +;;;; z streams and lexer +;;;; + +(defstruct zstream + token-category + token-semantic + input-stack) + +(defun call-with-zstream (fn zstream) + (unwind-protect + (funcall fn zstream) + (dolist (input (zstream-input-stack zstream)) + (cond #-x&y-streams-are-stream + ((xstream-p input) + (close-xstream input)) + #+x&y-streams-are-stream + ((streamp input) + (close input)))))) + +(defmacro with-zstream ((zstream &rest args) &body body) + `(call-with-zstream (lambda (,zstream) ,@body) + (make-zstream ,@args))) + +(defun read-token (input) + (cond ((zstream-token-category input) + (multiple-value-prog1 + (values (zstream-token-category input) + (zstream-token-semantic input)) + (setf (zstream-token-category input) nil + (zstream-token-semantic input) nil))) + (t + (read-token-2 input)))) + +(defun peek-token (input) + (cond ((zstream-token-category input) + (values + (zstream-token-category input) + (zstream-token-semantic input))) + (t + (multiple-value-bind (c s) (read-token input) + (setf (zstream-token-category input) c + (zstream-token-semantic input) s)) + (values (zstream-token-category input) + (zstream-token-semantic input))))) + +(defun read-token-2 (input) + (cond ((null (zstream-input-stack input)) + (values :eof nil)) + (t + (let ((c (peek-rune (car (zstream-input-stack input))))) + (cond ((eq c :eof) + (cond ((eq (cadr (zstream-input-stack input)) :stop) + (values :eof nil)) + (t + (close-xstream (pop (zstream-input-stack input))) + (if (null (zstream-input-stack input)) + (values :eof nil) + (values :S nil) ;fake #x20 after PE expansion + )))) + (t + (read-token-3 input))))))) + +(defvar *data-behaviour* + ) ;either :DTD or :DOC + +(defun read-token-3 (zinput) + (let ((input (car (zstream-input-stack zinput)))) + ;; PI Comment + (let ((c (read-rune input))) + (cond + ;; first the common tokens + ((rune= #/< c) + (read-token-after-|<| zinput input)) + ;; now dispatch + (t + (ecase *data-behaviour* + (:DTD + (cond ((rune= #/\[ c) :\[) + ((rune= #/\] c) :\]) + ((rune= #/$ c) :\() + ((rune= #/$ c) :\)) + ((rune= #/\| c) :\|) + ((rune= #/\> c) :\>) + ((rune= #/\" c) :\") + ((rune= #/\' c) :\') + ((rune= #/\, c) :\,) + ((rune= #/\? c) :\?) + ((rune= #/\* c) :\*) + ((rune= #/\+ c) :\+) + ((name-rune-p c) + (unread-rune c input) + (values :nmtoken (read-name-token input))) + ((rune= #/# c) + (let ((q (read-name-token input))) + (cond ((rod= q '#.(string-rod "REQUIRED")) :|#REQUIRED|) + ((rod= q '#.(string-rod "IMPLIED")) :|#IMPLIED|) + ((rod= q '#.(string-rod "FIXED")) :|#FIXED|) + ((rod= q '#.(string-rod "PCDATA")) :|#PCDATA|) + (t + (wf-error zinput "Unknown token: ~S." q))))) + ((or (rune= c #/U+0020) + (rune= c #/U+0009) + (rune= c #/U+000D) + (rune= c #/U+000A)) + (values :S nil)) + ((rune= #/% c) + (cond ((name-start-rune-p (peek-rune input)) + ;; an entity reference + (read-pe-reference zinput)) + (t + (values :%)))) + (t + (wf-error zinput "Unexpected character ~S." c)))) + (:DOC + (cond + ((rune= c #/&) + (multiple-value-bind (kind data) (read-entity-like input) + (cond ((eq kind :ENTITY-REFERENCE) + (values :ENTITY-REF data)) + ((eq kind :CHARACTER-REFERENCE) + (values :CDATA + (with-rune-collector (collect) + (%put-unicode-char data collect))))))) + (t + (unread-rune c input) + (values :CDATA (read-cdata input))))))))))) + +(definline check-rune (input actual expected) + (unless (eql actual expected) + (wf-error input "expected #/~A but found #/~A" + (rune-char expected) + (rune-char actual)))) + +(defun read-pe-reference (zinput) + (let* ((input (car (zstream-input-stack zinput))) + (nam (read-name-token input))) + (check-rune input #/\; (read-rune input)) + (cond (*expand-pe-p* + ;; no external entities here! + (let ((i2 (entity->xstream zinput nam :parameter))) + (zstream-push i2 zinput)) + (values :S nil) ;space before inserted PE expansion. + ) + (t + (values :PE-REFERENCE nam)) ))) + +(defun read-token-after-|<| (zinput input) + (let ((d (read-rune input))) + (cond ((eq d :eof) + (eox input "EOF after '<'")) + ((rune= #/! d) + (read-token-after-|<!| input)) + ((rune= #/? d) + (multiple-value-bind (target content) (read-pi input) + (cond ((rod= target '#.(string-rod "xml")) + (values :xml-decl (cons target content))) + ((rod-equal target '#.(string-rod "XML")) + (wf-error zinput + "You lost -- no XML processing instructions.")) + ((and sax:*namespace-processing* (position #/: target)) + (wf-error zinput + "Processing instruction target ~S is not a ~ + valid NcName." + (mu target))) + (t + (values :PI (cons target content)))))) + ((eq *data-behaviour* :DTD) + (unread-rune d input) + (unless (or (rune= #// d) (name-start-rune-p d)) + (wf-error zinput "Expected '!' or '?' after '<' in DTD.")) + (values :seen-< nil)) + ((rune= #// d) + (let ((c (peek-rune input))) + (cond ((name-start-rune-p c) + (read-tag-2 zinput input :etag)) + (t + (wf-error zinput + "Expecting name start rune after \"</\"."))))) + ((name-start-rune-p d) + (unread-rune d input) + (read-tag-2 zinput input :stag)) + (t + (wf-error zinput "Expected '!' or '?' after '<' in DTD."))))) + +(defun read-token-after-|<!| (input) + (let ((d (read-rune input))) + (cond ((eq d :eof) + (eox input "EOF after \"<!\".")) + ((name-start-rune-p d) + (unread-rune d input) + (let ((name (read-name-token input))) + (cond ((rod= name '#.(string-rod "ELEMENT")) :|<!ELEMENT|) + ((rod= name '#.(string-rod "ENTITY")) :|<!ENTITY|) + ((rod= name '#.(string-rod "ATTLIST")) :|<!ATTLIST|) + ((rod= name '#.(string-rod "NOTATION")) :|<!NOTATION|) + ((rod= name '#.(string-rod "DOCTYPE")) :|<!DOCTYPE|) + (t + (wf-error input"`<!~A' unknown." (rod-string name)))))) + ((rune= #/\[ d) + (values :|<![| nil)) + ((rune= #/- d) + (setf d (read-rune input)) + (cond ((rune= #/- d) + (values + :COMMENT + (read-comment-content input))) + (t + (wf-error input"Bad character ~S after \"<!-\"" d)))) + (t + (wf-error input "Bad character ~S after \"<!\"" d))))) + +(definline read-S? (input) + (while (member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D) + :test #'eql) + (consume-rune input))) + +(defun read-attribute-list (zinput input imagine-space-p) + (cond ((or imagine-space-p + (let ((c (peek-rune input))) + (and (not (eq c :eof)) + (space-rune-p c)))) + (read-S? input) + (cond ((eq (peek-rune input) :eof) + nil) + ((name-start-rune-p (peek-rune input)) + (cons (read-attribute zinput input) + (read-attribute-list zinput input nil))) + (t + nil))) + (t + nil))) + +(defun read-entity-like (input) + "Read an entity reference off the xstream `input'. Returns two values: + either :ENTITY-REFERENCE <interned-rod> in case of a named entity + or :CHARACTER-REFERENCE <integer> in case of character references. + The initial #\\& is considered to be consumed already." + (let ((c (peek-rune input))) + (cond ((eq c :eof) + (eox input "EOF after '&'")) + ((rune= c #/#) + (values :CHARACTER-REFERENCE (read-character-reference input))) + (t + (unless (name-start-rune-p (peek-rune input)) + (wf-error input "Expecting name after &.")) + (let ((name (read-name-token input))) + (setf c (read-rune input)) + (unless (rune= c #/\;) + (wf-error input "Expected \";\".")) + (values :ENTITY-REFERENCE name)))))) + +(defun read-tag-2 (zinput input kind) + (let ((name (read-name-token input)) + (atts nil)) + (setf atts (read-attribute-list zinput input nil)) + + ;; check for double attributes + (do ((q atts (cdr q))) + ((null q)) + (cond ((find (caar q) (cdr q) :key #'car) + (wf-error zinput "Attribute ~S has two definitions in element ~S." + (rod-string (caar q)) + (rod-string name))))) + + (cond ((eq (peek-rune input) #/>) + (consume-rune input) + (values kind (cons name atts))) + ((eq (peek-rune input) #//) + (consume-rune input) + (check-rune input #/> (read-rune input)) + (values :ztag (cons name atts))) + (t + (wf-error zinput "syntax error in read-tag-2.")) ))) + +(defun read-attribute (zinput input) + (unless (name-start-rune-p (peek-rune input)) + (wf-error zinput "Expected name.")) + ;; arg thanks to the post mortem nature of name space declarations, + ;; we could only process the attribute values post mortem. + (let ((name (read-name-token input))) + (while (let ((c (peek-rune input))) + (and (not (eq c :eof)) + (or (rune= c #/U+0020) + (rune= c #/U+0009) + (rune= c #/U+000A) + (rune= c #/U+000D)))) + (consume-rune input)) + (unless (eq (read-rune input) #/=) + (wf-error zinput "Expected \"=\".")) + (while (let ((c (peek-rune input))) + (and (not (eq c :eof)) + (or (rune= c #/U+0020) + (rune= c #/U+0009) + (rune= c #/U+000A) + (rune= c #/U+000D)))) + (consume-rune input)) + (cons name (read-att-value-2 input)))) + +(defun canon-not-cdata-attval (value) + ;; | If the declared value is not CDATA, then the XML processor must + ;; | further process the normalized attribute value by discarding any + ;; | leading and trailing space (#x20) characters, and by replacing + ;; | sequences of space (#x20) characters by a single space (#x20) + ;; | character. + (with-rune-collector (collect) + (let ((gimme-20 nil) + (anything-seen-p nil)) + (map nil (lambda (c) + (cond ((rune= c #/u+0020) + (setf gimme-20 t)) + (t + (when (and anything-seen-p gimme-20) + (collect #/u+0020)) + (setf gimme-20 nil) + (setf anything-seen-p t) + (collect c)))) + value)))) + +(definline data-rune-p (rune) + ;; any Unicode character, excluding the surrogate blocks, FFFE, and FFFF. + ;; + ;; FIXME: das halte ich fuer verkehrt. Surrogates als Unicode-Zeichen + ;; sind verboten. Das liegt hier aber nicht vor, denn wir arbeiten + ;; ja tatsaechlich mit UTF-16. Verboten ist es nur, wenn wir ein + ;; solches Zeichen beim Dekodieren finden, das wird aber eben + ;; in encodings.lisp bereits geprueft. --david + (let ((c (rune-code rune))) + (or (= c #x9) (= c #xA) (= c #xD) + (<= #x20 c #xD7FF) + (<= #xE000 c #xFFFD) + (<= #xD800 c #xDBFF) + (<= #xDC00 c #xDFFF)))) + +(defun read-att-value (zinput input mode &optional canon-space-p (delim nil)) + (with-rune-collector-2 (collect) + (labels ((muffle (input delim) + (let (c) + (loop + (setf c (read-rune input)) + (cond ((eql delim c) + (return)) + ((eq c :eof) + (eox input "EOF")) + ((rune= c #/&) + (setf c (peek-rune input)) + (cond ((eql c :eof) + (eox input)) + ((rune= c #/#) + (let ((c (read-character-reference input))) + (%put-unicode-char c collect))) + (t + (unless (name-start-rune-p (peek-rune input)) + (wf-error zinput "Expecting name after &.")) + (let ((name (read-name-token input))) + (setf c (read-rune input)) + (check-rune input c #/\;) + (ecase mode + (:ATT + (recurse-on-entity + zinput name :general + (lambda (zinput) + (muffle (car (zstream-input-stack zinput)) + :eof)) + t)) + (:ENT + ;; bypass, but never the less we + ;; need to check for legal + ;; syntax. + ;; Must it be defined? + ;; allerdings: unparsed sind verboten + (collect #/&) + (map nil (lambda (x) (collect x)) name) + (collect #/\; ))))))) + ((and (eq mode :ENT) (rune= c #/%)) + (let ((d (peek-rune input))) + (when (eq d :eof) + (eox input)) + (unless (name-start-rune-p d) + (wf-error zinput "Expecting name after %."))) + (let ((name (read-name-token input))) + (setf c (read-rune input)) + (check-rune input c #/\;) + (cond (*expand-pe-p* + (recurse-on-entity + zinput name :parameter + (lambda (zinput) + (muffle (car (zstream-input-stack zinput)) + :eof)))) + (t + (wf-error zinput "No PE here."))))) + ((and (eq mode :ATT) (rune= c #/<)) + (wf-error zinput "unexpected #\/<")) + ((and canon-space-p (space-rune-p c)) + (collect #/space)) + ((not (data-rune-p c)) + (wf-error zinput "illegal char: ~S." c)) + (t + (collect c))))))) + (declare (dynamic-extent #'muffle)) + (muffle input (or delim + (let ((delim (read-rune input))) + (unless (member delim '(#/\" #/\') :test #'eql) + (wf-error zinput "invalid attribute delimiter")) + delim)))))) + +(defun read-character-reference (input) + ;; The #/& is already read + (let ((res + (let ((c (read-rune input))) + (check-rune input c #/#) + (setq c (read-rune input)) + (cond ((eql c :eof) + (eox input)) + ((eql c #/x) + ;; hexadecimal + (setq c (read-rune input)) + (when (eql c :eof) + (eox input)) + (unless (digit-rune-p c 16) + (wf-error input "garbage in character reference")) + (prog1 + (parse-integer + (with-output-to-string (sink) + (write-char (rune-char c) sink) + (while (progn + (setq c (read-rune input)) + (when (eql c :eof) + (eox input)) + (digit-rune-p c 16)) + (write-char (rune-char c) sink))) + :radix 16) + (check-rune input c #/\;))) + ((rune<= #/0 c #/9) + ;; decimal + (prog1 + (parse-integer + (with-output-to-string (sink) + (write-char (rune-char c) sink) + (while (progn + (setq c (read-rune input)) + (when (eql c :eof) + (eox input)) + (rune<= #/0 c #/9)) + (write-char (rune-char c) sink))) + :radix 10) + (check-rune input c #/\;))) + (t + (wf-error input "Bad char in numeric character entity.")))))) + (unless (code-data-char-p res) + (wf-error + input + "expansion of numeric character reference (#x~X) is no data char." + res)) + res)) + +(defun read-pi (input) + ;; "<?" is already read + (let (name) + (let ((c (peek-rune input))) + (unless (name-start-rune-p c) + (wf-error input "Expecting name after '<?'")) + (setf name (read-name-token input))) + (cond + ((member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D) + :test #'eql) + (values name (read-pi-content input))) + (t + (unless (and (eql (read-rune input) #/?) + (eql (read-rune input) #/>)) + (wf-error input "malformed processing instruction")) + (values name ""))))) + +(defun read-pi-content (input) + (read-S? input) + (let (d) + (with-rune-collector (collect) + (block nil + (tagbody + state-1 + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/?) (go state-2)) + (collect d) + (go state-1) + state-2 ;; #/? seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/>) (return)) + (when (rune= d #/?) + (collect #/?) + (go state-2)) + (collect #/?) + (collect d) + (go state-1)))))) + +(defun read-comment-content (input &aux d) + (with-rune-collector (collect) + (block nil + (tagbody + state-1 + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/-) (go state-2)) + (collect d) + (go state-1) + state-2 ;; #/- seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/-) (go state-3)) + (collect #/-) + (collect d) + (go state-1) + state-3 ;; #/- #/- seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/>) (return)) + (wf-error input "'--' not allowed in a comment") + (when (rune= d #/-) + (collect #/-) + (go state-3)) + (collect #/-) + (collect #/-) + (collect d) + (go state-1))))) + +(defun read-cdata-sect (input &aux d) + ;; <![CDATA[ is already read + ;; read anything up to ]]> + (with-rune-collector (collect) + (block nil + (tagbody + state-1 + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/\]) (go state-2)) + (collect d) + (go state-1) + state-2 ;; #/] seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/\]) (go state-3)) + (collect #/\]) + (collect d) + (go state-1) + state-3 ;; #/\] #/\] seen + (setf d (read-rune input)) + (when (eq d :eof) + (eox input)) + (unless (data-rune-p d) + (wf-error input "Illegal char: ~S." d)) + (when (rune= d #/>) + (return)) + (when (rune= d #/\]) + (collect #/\]) + (go state-3)) + (collect #/\]) + (collect #/\]) + (collect d) + (go state-1))))) + +;; some character categories + +(defun space-rune-p (rune) + (declare (type rune rune)) + (or (rune= rune #/U+0020) + (rune= rune #/U+0009) + (rune= rune #/U+000A) + (rune= rune #/U+000D))) + +(defun code-data-char-p (c) + ;; any Unicode character, excluding the surrogate blocks, FFFE, and FFFF. + (or (= c #x9) (= c #xA) (= c #xD) + (<= #x20 c #xD7FF) + (<= #xE000 c #xFFFD) + (<= #x10000 c #x10FFFF))) + +(defun pubid-char-p (c) + (or (rune= c #/u+0020) (rune= c #/u+000D) (rune= c #/u+000A) + (rune<= #/a c #/z) + (rune<= #/A c #/Z) + (rune<= #/0 c #/9) + (member c '(#/- #/' #/$ #/$ #/+ #/, #/. #// + #/: #/= #/? #/\; #/! #/* #/# + #/@ #/$ #/_ #/%)))) + + +(defun expect (input category) + (multiple-value-bind (cat sem) (read-token input) + (unless (eq cat category) + (wf-error input "Expected ~S saw ~S [~S]" category cat sem)) + (values cat sem))) + +(defun consume-token (input) + (read-token input)) + +;;;; --------------------------------------------------------------------------- +;;;; Parser +;;;; + +(defun p/S (input) + ;; S ::= (#x20 | #x9 | #xD | #xA)+ + (expect input :S) + (while (eq (peek-token input) :S) + (consume-token input))) + +(defun p/S? (input) + ;; S ::= (#x20 | #x9 | #xD | #xA)+ + (while (eq (peek-token input) :S) + (consume-token input))) + +(defun p/nmtoken (input) + (nth-value 1 (expect input :nmtoken))) + +(defun p/name (input) + (let ((result (p/nmtoken input))) + (unless (name-start-rune-p (elt result 0)) + (wf-error input "Expected name.")) + result)) + +(defun p/attlist-decl (input) + ;; [52] AttlistDecl ::= '<!ATTLIST' S Name (S AttDef)* S? '>' + (let (elm-name) + (expect input :|<!ATTLIST|) + (p/S input) + (setf elm-name (p/nmtoken input)) + (loop + (let ((tok (read-token input))) + (case tok + (:S + (p/S? input) + (cond ((eq (peek-token input) :>) + (consume-token input) + (return)) + (t + (multiple-value-bind (name type default) (p/attdef input) + (define-attribute (dtd *ctx*) elm-name name type default)) ))) + (:> + (return)) + (otherwise + (wf-error input + "Expected either another AttDef or end of \"<!ATTLIST\". -- saw ~S." + tok))))))) + +(defun p/attdef (input) + ;; [53] AttDef ::= Name S AttType S DefaultDecl + (let (name type default) + (setf name (p/nmtoken input)) + (p/S input) + (setf type (p/att-type input)) + (p/S input) + (setf default (p/default-decl input)) + (values name type default))) + +(defun p/list (input item-parser delimiter) + ;; Parse something like S? <item> (S? <delimiter> <item>)* S? + ;; + (declare (type function item-parser)) + (let (res) + (p/S? input) + (setf res (list (funcall item-parser input))) + (loop + (p/S? input) + (cond ((eq (peek-token input) delimiter) + (consume-token input) + (p/S? input) + (push (funcall item-parser input) res)) + (t + (return)))) + (p/S? input) + (reverse res))) + +(defun p/att-type (input) + ;; [54] AttType ::= StringType | TokenizedType | EnumeratedType + ;; [55] StringType ::= 'CDATA' + ;; [56] TokenizedType ::= 'ID' /*VC: ID */ + ;; /*VC: One ID per Element Type */ + ;; /*VC: ID Attribute Default */ + ;; | 'IDREF' /*VC: IDREF */ + ;; | 'IDREFS' /*VC: IDREF */ + ;; | 'ENTITY' /*VC: Entity Name */ + ;; | 'ENTITIES' /*VC: Entity Name */ + ;; | 'NMTOKEN' /*VC: Name Token */ + ;; | 'NMTOKENS' /*VC: Name Token */ + ;; [57] EnumeratedType ::= NotationType | Enumeration + ;; [58] NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')' + ;; /* VC: Notation Attributes */ + ;; [59] Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' /* VC: Enumeration */ + (multiple-value-bind (cat sem) (read-token input) + (cond ((eq cat :nmtoken) + (cond ((rod= sem '#.(string-rod "CDATA")) :CDATA) + ((rod= sem '#.(string-rod "ID")) :ID) + ((rod= sem '#.(string-rod "IDREF")) :IDREFS) + ((rod= sem '#.(string-rod "IDREFS")) :IDREFS) + ((rod= sem '#.(string-rod "ENTITY")) :ENTITY) + ((rod= sem '#.(string-rod "ENTITIES")) :ENTITIES) + ((rod= sem '#.(string-rod "NMTOKEN")) :NMTOKEN) + ((rod= sem '#.(string-rod "NMTOKENS")) :NMTOKENS) + ((rod= sem '#.(string-rod "NOTATION")) + (let (names) + (p/S input) + (expect input :$) + (setf names (p/list input #'p/nmtoken :\| )) + (expect input :$) + (when *validate* + (setf (referenced-notations *ctx*) + (append names (referenced-notations *ctx*)))) + (cons :NOTATION names))) + (t + (wf-error input "In p/att-type: ~S ~S." cat sem)))) + ((eq cat :$) + ;; XXX Die Nmtoken-Syntax pruefen wir derzeit nur beim Validieren. + (let (names) + ;;(expect input :\() + (setf names (p/list input #'p/nmtoken :\| )) + (expect input :$) + (cons :ENUMERATION names))) + (t + (wf-error input "In p/att-type: ~S ~S." cat sem)) ))) + +(defun p/default-decl (input) + ;; [60] DefaultDecl ::= '#REQUIRED' | '#IMPLIED' + ;; | (('#FIXED' S)? AttValue) /* VC: Required Attribute */ + ;; + ;; /* VC: Attribute Default Legal */ + ;; /* WFC: No < in Attribute Values */ + ;; /* VC: Fixed Attribute Default */ + (multiple-value-bind (cat sem) (peek-token input) + (cond ((eq cat :|#REQUIRED|) + (consume-token input) :REQUIRED) + ((eq cat :|#IMPLIED|) + (consume-token input) :IMPLIED) + ((eq cat :|#FIXED|) + (consume-token input) + (p/S input) + (list :FIXED (p/att-value input))) + ((or (eq cat :\') (eq cat :\")) + (list :DEFAULT (p/att-value input))) + (t + (wf-error input "p/default-decl: ~S ~S." cat sem)) ))) +;;;; + +;; [70] EntityDecl ::= GEDecl | PEDecl +;; [71] GEDecl ::= '<!ENTITY' S Name S EntityDef S? '>' +;; [72] PEDecl ::= '<!ENTITY' S '%' S Name S PEDef S? '>' +;; [73] EntityDef ::= EntityValue | (ExternalID NDataDecl?) +;; [74] PEDef ::= EntityValue | ExternalID +;; [75] ExternalID ::= 'SYSTEM' S SystemLiteral +;; | 'PUBLIC' S PubidLiteral S SystemLiteral +;; [76] NDataDecl ::= S 'NDATA' S Name /* VC: Notation Declared */ + +(defun p/entity-decl (input) + (let (name def kind) + (expect input :|<!ENTITY|) + (p/S input) + (cond ((eq (peek-token input) :%) + (setf kind :parameter) + (consume-token input) + (p/S input)) + (t + (setf kind :general))) + (setf name (p/name input)) + (p/S input) + (setf def (p/entity-def input kind)) + (define-entity input name kind def) + (p/S? input) + (expect input :\>))) + +(defun report-entity (h kind name def) + (etypecase def + (external-entdef + (let ((extid (entdef-extid def)) + (ndata (entdef-ndata def))) + (if ndata + (sax:unparsed-entity-declaration h + name + (extid-public extid) + (uri-rod (extid-system extid)) + ndata) + (sax:external-entity-declaration h + kind + name + (extid-public extid) + (uri-rod (extid-system extid)))))) + (internal-entdef + (sax:internal-entity-declaration h kind name (entdef-value def))))) + +(defun p/entity-def (input kind) + (multiple-value-bind (cat sem) (peek-token input) + (cond ((member cat '(:\" :\')) + (make-internal-entdef (p/entity-value input))) + ((and (eq cat :nmtoken) + (or (rod= sem '#.(string-rod "SYSTEM")) + (rod= sem '#.(string-rod "PUBLIC")))) + (let (extid ndata) + (setf extid (p/external-id input nil)) + (when (eq kind :general) ;NDATA allowed at all? + (cond ((eq (peek-token input) :S) + (p/S? input) + (when (and (eq (peek-token input) :nmtoken) + (rod= (nth-value 1 (peek-token input)) + '#.(string-rod "NDATA"))) + (consume-token input) + (p/S input) + (setf ndata (p/nmtoken input)) + (when *validate* + (push ndata (referenced-notations *ctx*))))))) + (make-external-entdef extid ndata))) + (t + (wf-error input "p/entity-def: ~S / ~S." cat sem)) ))) + +(defun p/entity-value (input) + (let ((delim (if (eq (read-token input) :\") #/\" #/\'))) + (read-att-value input + (car (zstream-input-stack input)) + :ENT + nil + delim))) + +(defun p/att-value (input) + (let ((delim (if (eq (read-token input) :\") #/\" #/\'))) + (read-att-value input + (car (zstream-input-stack input)) + :ATT + t + delim))) + +(defun p/external-id (input &optional (public-only-ok-p nil)) + ;; xxx public-only-ok-p + (multiple-value-bind (cat sem) (read-token input) + (cond ((and (eq cat :nmtoken) (rod= sem '#.(string-rod "SYSTEM"))) + (p/S input) + (make-extid nil (p/system-literal input))) + ((and (eq cat :nmtoken) (rod= sem '#.(string-rod "PUBLIC"))) + (let (pub sys) + (p/S input) + (setf pub (p/pubid-literal input)) + (when (eq (peek-token input) :S) + (p/S input) + (when (member (peek-token input) '(:\" :\')) + (setf sys (p/system-literal input)))) + (when (and (not public-only-ok-p) + (null sys)) + (wf-error input "System identifier needed for this PUBLIC external identifier.")) + (make-extid pub sys))) + (t + (wf-error input "Expected external-id: ~S / ~S." cat sem))))) + + +;; [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") +;; [12] PubidLiteral ::= '"' PubidChar* '"' | "'" (PubidChar - "'")* "'" +;; [13] PubidChar ::= #x20 | #xD | #xA | [a-zA-Z0-9] +;; | [-'()+,./:=?;!*#@$_%] + +(defun p/id (input) + (multiple-value-bind (cat) (read-token input) + (cond ((member cat '(:\" :\')) + (let ((delim (if (eq cat :\") #/\" #/\'))) + (with-rune-collector (collect) + (loop + (let ((c (read-rune (car (zstream-input-stack input))))) + (cond ((eq c :eof) + (eox input "EOF in system literal.")) + ((rune= c delim) + (return)) + (t + (collect c)))))))) + (t + (wf-error input "Expect either \" or \'."))))) + +;; it is important to cache the orginal URI rod, since the re-serialized +;; uri-string can be different from the one parsed originally. +(defun uri-rod (uri) + (if uri + (or (getf (puri:uri-plist uri) 'original-rod) + (rod (puri:render-uri uri nil))) + nil)) + +(defun safe-parse-uri (str) + ;; puri doesn't like strings starting with file:///, although that is a very + ;; common is practise. Cut it away, we don't distinguish between scheme + ;; :FILE and NIL anway. + (when (eql (search "file://" str) 0) + (setf str (subseq str (length "file://")))) + (puri:parse-uri (coerce str 'simple-string))) + +(defun p/system-literal (input) + (let* ((rod (p/id input)) + (result (safe-parse-uri (rod-string rod)))) + (setf (getf (puri:uri-plist result) 'original-rod) rod) + result)) + +(defun p/pubid-literal (input) + (let ((result (p/id input))) + (unless (every #'pubid-char-p result) + (wf-error input "Illegal pubid: ~S." (rod-string result))) + result)) + + +;;;; + +(defun p/element-decl (input) + (let (name content) + (expect input :|<!ELEMENT|) + (p/S input) + (setf name (p/nmtoken input)) + (p/S input) + (setf content (normalize-mixed-cspec (p/cspec input))) + (unless (legal-content-model-p content *validate*) + (wf-error input "Malformed or invalid content model: ~S." (mu content))) + (p/S? input) + (expect input :\>) + (when *validate* + (define-element (dtd *ctx*) name content)) + (list :element name content))) + +(defun maybe-compile-cspec (e) + (or (elmdef-compiled-cspec e) + (setf (elmdef-compiled-cspec e) + (let ((cspec (elmdef-content e))) + (unless cspec + (validity-error "(03) Element Valid: no definition for ~A" + (rod-string (elmdef-name e)))) + (multiple-value-call #'cons + (compile-cspec cspec (standalone-check-necessary-p e))))))) + +(defun make-root-model (name) + (cons (lambda (actual-name) + (if (rod= actual-name name) + (constantly :dummy) + nil)) + (constantly t))) + +;;; content spec validation: +;;; +;;; Given a `contentspec', COMPILE-CSPEC returns as multiple values two +;;; functions A and B of one argument to be called for every +;;; A. child element +;;; B. text child node +;;; +;;; Function A will be called with +;;; - the element name rod as its argument. If that element may appear +;;; at the current position, a new function to be called for the next +;;; child is returned. Otherwise NIL is returned. +;;; - argument NIL at the end of the element, it must then return T or NIL +;;; to indicate whether the end tag is valid. +;;; +;;; Function B will be called with the character data rod as its argument, it +;;; returns a boolean indicating whether this text node is allowed. +;;; +;;; That is, if one of the functions ever returns NIL, the node is +;;; rejected as invalid. + +(defun cmodel-done (actual-value) + (null actual-value)) + +(defun compile-cspec (cspec &optional standalone-check) + (cond + ((atom cspec) + (ecase cspec + (:EMPTY (values #'cmodel-done (constantly nil))) + (:PCDATA (values #'cmodel-done (constantly t))) + (:ANY + (values (labels ((doit (name) (if name #'doit t))) #'doit) + (constantly t))))) + ((and (eq (car cspec) '*) + (let ((subspec (second cspec))) + (and (eq (car subspec) 'or) (eq (cadr subspec) :PCDATA)))) + (values (compile-mixed (second cspec)) + (constantly t))) + (t + (values (compile-content-model cspec) + (lambda (rod) + (when standalone-check + (validity-error "(02) Standalone Document Declaration: whitespace")) + (every #'white-space-rune-p rod)))))) + +(defun compile-mixed (cspec) + ;; das koennten wir theoretisch auch COMPILE-CONTENT-MODEL erledigen lassen + (let ((allowed-names (cddr cspec))) + (labels ((doit (actual-name) + (cond + ((null actual-name) t) + ((member actual-name allowed-names :test #'rod=) #'doit) + (t nil)))) + #'doit))) + +(defun compile-content-model (cspec &optional (continuation #'cmodel-done)) + (if (vectorp cspec) + (lambda (actual-name) + (if (and actual-name (rod= cspec actual-name)) + continuation + nil)) + (ecase (car cspec) + (and + (labels ((traverse (seq) + (compile-content-model (car seq) + (if (cdr seq) + (traverse (cdr seq)) + continuation)))) + (traverse (cdr cspec)))) + (or + (let ((options (mapcar (rcurry #'compile-content-model continuation) + (cdr cspec)))) + (lambda (actual-name) + (some (rcurry #'funcall actual-name) options)))) + (? + (let ((maybe (compile-content-model (second cspec) continuation))) + (lambda (actual-name) + (or (funcall maybe actual-name) + (funcall continuation actual-name))))) + (* + (let (maybe-continuation) + (labels ((recurse (actual-name) + (if (null actual-name) + (funcall continuation actual-name) + (or (funcall maybe-continuation actual-name) + (funcall continuation actual-name))))) + (setf maybe-continuation + (compile-content-model (second cspec) #'recurse)) + #'recurse))) + (+ + (let ((it (cadr cspec))) + (compile-content-model `(and ,it (* ,it)) continuation)))))) + +(defun setp (list &key (test 'eql)) + (equal list (remove-duplicates list :test test))) + +(defun legal-content-model-p (cspec &optional validate) + (or (eq cspec :PCDATA) + (eq cspec :ANY) + (eq cspec :EMPTY) + (and (consp cspec) + (eq (car cspec) '*) + (consp (cadr cspec)) + (eq (car (cadr cspec)) 'or) + (eq (cadr (cadr cspec)) :PCDATA) + (every #'vectorp (cddr (cadr cspec))) + (if (and validate (not (setp (cddr (cadr cspec)) :test #'rod=))) + (validity-error "VC: No Duplicate Types (07)") + t)) + (labels ((walk (x) + (cond ((member x '(:PCDATA :ANY :EMPTY)) + nil) + ((atom x) t) + ((and (walk (car x)) + (walk (cdr x))))))) + (walk cspec)))) + +;; wir fahren besser, wenn wir machen: + +;; cspec ::= 'EMPTY' | 'ANY' | '#PCDATA' +;; | Name +;; | cs +;; cs ::= '(' S? cspec ( S? '|' S? cspec)* S? ')' ('?' | '*' | '+')? +;; und eine post factum analyse + +(defun p/cspec (input &optional recursivep) + (let ((term + (let ((names nil) op-cat op res stream) + (multiple-value-bind (cat sem) (peek-token input) + (cond ((eq cat :nmtoken) + (consume-token input) + (cond ((rod= sem '#.(string-rod "EMPTY")) + :EMPTY) + ((rod= sem '#.(string-rod "ANY")) + :ANY) + ((not recursivep) + (wf-error input "invalid content spec")) + (t + sem))) + ((eq cat :\#PCDATA) + (consume-token input) + :PCDATA) + ((eq cat :$) + (setf stream (car (zstream-input-stack input))) + (consume-token input) + (p/S? input) + (setq names (list (p/cspec input t))) + (p/S? input) + (cond ((member (peek-token input) '(:\| :\,)) + (setf op-cat (peek-token input)) + (setf op (if (eq op-cat :\,) 'and 'or)) + (while (eq (peek-token input) op-cat) + (consume-token input) + (p/S? input) + (push (p/cspec input t) names) + (p/S? input)) + (setf res (cons op (reverse names)))) + (t + (setf res (cons 'and names)))) + (p/S? input) + (expect input :$) + (when *validate* + (unless (eq stream (car (zstream-input-stack input))) + (validity-error "(06) Proper Group/PE Nesting"))) + res) + (t + (wf-error input "p/cspec - ~s / ~s" cat sem))))))) + (cond ((eq (peek-token input) :?) (consume-token input) (list '? term)) + ((eq (peek-token input) :+) (consume-token input) (list '+ term)) + ((eq (peek-token input) :*) (consume-token input) (list '* term)) + (t + term)))) + +(defun normalize-mixed-cspec (cspec) + ;; der Parser oben funktioniert huebsch fuer die children-Regel, aber + ;; fuer Mixed ist das Ergebnis nicht praktisch, denn dort wollen wir + ;; eigentlich auf eine Liste von Namen in einheitlichem Format hinaus. + ;; Dazu normalisieren wir einfach in eine der beiden folgenden Formen: + ;; (* (or :PCDATA ...rods...)) -- und zwar exakt so! + ;; :PCDATA -- sonst ganz trivial + (flet ((trivialp (c) + (and (consp c) + (and (eq (car c) 'and) + (eq (cadr c) :PCDATA) + (null (cddr c)))))) + (if (or (trivialp cspec) ;(and PCDATA) + (and (consp cspec) ;(* (and PCDATA)) + (and (eq (car cspec) '*) + (null (cddr cspec)) + (trivialp (cadr cspec))))) + :PCDATA + cspec))) + +;; [52] AttlistDecl ::= '<!ATTLIST' S Name AttDef* S? '>' + + +;; [52] AttlistDecl ::= '<!ATTLIST' S Name AttDefs S? '>' +;; [52] AttlistDecl ::= '<!ATTLIST' S Name S? '>' +;; [53] AttDefs ::= S Name S AttType S DefaultDecl AttDefs +;; [53] AttDefs ::= + +(defun p/notation-decl (input) + (let (name id) + (expect input :|<!NOTATION|) + (p/S input) + (setf name (p/name input)) + (p/S input) + (setf id (p/external-id input t)) + (p/S? input) + (expect input :\>) + (sax:notation-declaration (handler *ctx*) + name + (if (extid-public id) + (normalize-public-id (extid-public id)) + nil) + (uri-rod (extid-system id))) + (when (and sax:*namespace-processing* (find #/: name)) + (wf-error input "colon in notation name")) + (when *validate* + (define-notation (dtd *ctx*) name id)) + (list :notation-decl name id))) + +(defun normalize-public-id (rod) + (with-rune-collector (collect) + (let ((gimme-20 nil) + (anything-seen-p nil)) + (map nil (lambda (c) + (cond + ((or (rune= c #/u+0009) + (rune= c #/u+000A) + (rune= c #/u+000D) + (rune= c #/u+0020)) + (setf gimme-20 t)) + (t + (when (and anything-seen-p gimme-20) + (collect #/u+0020)) + (setf gimme-20 nil) + (setf anything-seen-p t) + (collect c)))) + rod)))) + +;;; + +(defun p/conditional-sect (input) + (expect input :<!\[ ) + (let ((stream (car (zstream-input-stack input)))) + (p/S? input) + (multiple-value-bind (cat sem) (read-token input) + (cond ((and (eq cat :nmtoken) + (rod= sem '#.(string-rod "INCLUDE"))) + (p/include-sect input stream)) + ((and (eq cat :nmtoken) + (rod= sem '#.(string-rod "IGNORE"))) + (p/ignore-sect input stream)) + (t + (wf-error input "Expected INCLUDE or IGNORE after \"<![\".")))))) + +(defun p/cond-expect (input cat initial-stream) + (expect input cat) + (when *validate* + (unless (eq (car (zstream-input-stack input)) initial-stream) + (validity-error "(21) Proper Conditional Section/PE Nesting")))) + +(defun p/include-sect (input initial-stream) + ;; <![INCLUDE is already read. + (p/S? input) + (p/cond-expect input :\[ initial-stream) + (p/ext-subset-decl input) + (p/cond-expect input :\] initial-stream) + (p/cond-expect input :\] initial-stream) + (p/cond-expect input :\> initial-stream)) + +(defun p/ignore-sect (input initial-stream) + ;; <![IGNORE is already read. + ;; XXX Is VC 21 being checked for nested sections? + (p/S? input) + (p/cond-expect input :\[ initial-stream) + (let ((input (car (zstream-input-stack input)))) + (let ((level 0)) + (do ((c1 (read-rune input) (read-rune input)) + (c2 #/U+0000 c1) + (c3 #/U+0000 c2)) + ((= level -1)) + (declare (type fixnum level)) + (cond ((eq c1 :eof) + (eox input "EOF in <![IGNORE ... >"))) + (cond ((and (rune= c3 #/<) (rune= c2 #/!) (rune= c1 #/\[)) + (incf level))) + (cond ((and (rune= c3 #/\]) (rune= c2 #/\]) (rune= c1 #/>)) + (decf level))) ))) + (unless (eq (car (zstream-input-stack input)) initial-stream) + (validity-error "(21) Proper Conditional Section/PE Nesting"))) + +(defun p/ext-subset-decl (input) + ;; ( markupdecl | conditionalSect | S )* + (loop + (case (let ((*expand-pe-p* nil)) (peek-token input)) + (:|<![| (let ((*expand-pe-p* t)) (p/conditional-sect input))) + (:S (consume-token input)) + (:eof (return)) + ((:|<!ELEMENT| :|<!ATTLIST| :|<!ENTITY| :|<!NOTATION| :PI :COMMENT) + (let ((*expand-pe-p* t) + (*external-subset-p* t)) + (p/markup-decl input))) + ((:PE-REFERENCE) + (let ((name (nth-value 1 (read-token input)))) + (recurse-on-entity input name :parameter + (lambda (input) + (etypecase (checked-get-entdef name :parameter) + (external-entdef + (p/ext-subset input)) + (internal-entdef + (p/ext-subset-decl input))) + (unless (eq :eof (peek-token input)) + (wf-error input "Trailing garbage.")))))) + (otherwise (return)))) ) + +(defun p/markup-decl (input) + (peek-token input) + (let ((stream (car (zstream-input-stack input)))) + (multiple-value-prog1 + (p/markup-decl-unsafe input) + (when *validate* + (unless (eq stream (car (zstream-input-stack input))) + (validity-error "(01) Proper Declaration/PE Nesting")))))) + +(defun p/markup-decl-unsafe (input) + ;; markupdecl ::= elementdecl | AttlistDecl /* VC: Proper Declaration/PE Nesting */ + ;; | EntityDecl | NotationDecl + ;; | PI | Comment /* WFC: PEs in Internal Subset */ + (let ((token (peek-token input)) + (*expand-pe-p* (and *expand-pe-p* *external-subset-p*))) + (case token + (:|<!ELEMENT| (p/element-decl input)) + (:|<!ATTLIST| (p/attlist-decl input)) + (:|<!ENTITY| (p/entity-decl input)) + (:|<!NOTATION| (p/notation-decl input)) + (:PI + (let ((sem (nth-value 1 (read-token input)))) + (sax:processing-instruction (handler *ctx*) (car sem) (cdr sem)))) + (:COMMENT (consume-token input)) + (otherwise + (wf-error input "p/markup-decl ~S" (peek-token input)))))) + +(defun setup-encoding (input xml-header) + (when (xml-header-encoding xml-header) + (let ((enc (find-encoding (xml-header-encoding xml-header)))) + (cond (enc + (setf (xstream-encoding (car (zstream-input-stack input))) + enc)) + (t + (warn "There is no such encoding: ~S." (xml-header-encoding xml-header))))))) + +(defun set-full-speed (input) + (let ((xstream (car (zstream-input-stack input)))) + (when xstream + (set-to-full-speed xstream)))) + +(defun p/ext-subset (input) + (cond ((eq (peek-token input) :xml-decl) + (let ((hd (parse-text-decl (cdr (nth-value 1 (peek-token input)))))) + (setup-encoding input hd)) + (consume-token input))) + (set-full-speed input) + (p/ext-subset-decl input) + (unless (eq (peek-token input) :eof) + (wf-error input "Trailing garbage - ~S." (peek-token input)))) + +(defvar *catalog* nil) + +(defun extid-using-catalog (extid) + (if *catalog* + (let ((sysid + (resolve-extid (extid-public extid) + (extid-system extid) + *catalog*))) + (if sysid + (make-extid nil sysid) + extid)) + extid)) + +(defun p/doctype-decl (input &optional dtd-extid) + (let () + (let ((*expand-pe-p* nil) + name extid) + (expect input :|<!DOCTYPE|) + (p/S input) + (setq name (p/nmtoken input)) + (when *validate* + (setf (model-stack *ctx*) (list (make-root-model name)))) + (when (eq (peek-token input) :S) + (p/S input) + (unless (or (eq (peek-token input) :\[ ) + (eq (peek-token input) :\> )) + (setf extid (p/external-id input t)))) + (when dtd-extid + (setf extid dtd-extid)) + (p/S? input) + (sax:start-dtd (handler *ctx*) + name + (and extid (extid-public extid)) + (and extid (uri-rod (extid-system extid)))) + (when (eq (peek-token input) :\[ ) + (when (disallow-internal-subset *ctx*) + (wf-error input "document includes an internal subset")) + (ensure-dtd) + (consume-token input) + (sax:start-internal-subset (handler *ctx*)) + (while (progn (p/S? input) + (not (eq (peek-token input) :\] ))) + (if (eq (peek-token input) :PE-REFERENCE) + (let ((name (nth-value 1 (read-token input)))) + (recurse-on-entity input name :parameter + (lambda (input) + (etypecase (checked-get-entdef name :parameter) + (external-entdef + (p/ext-subset input)) + (internal-entdef + (p/ext-subset-decl input))) + (unless (eq :eof (peek-token input)) + (wf-error input "Trailing garbage."))))) + (let ((*expand-pe-p* t)) + (p/markup-decl input)))) + (consume-token input) + (sax:end-internal-subset (handler *ctx*)) + (p/S? input)) + (expect input :>) + (when extid + (let* ((effective-extid + (extid-using-catalog (absolute-extid input extid))) + (sysid (extid-system effective-extid)) + (fresh-dtd-p (null (dtd *ctx*))) + (cached-dtd + (and fresh-dtd-p + (not (standalone-p *ctx*)) + (getdtd sysid *dtd-cache*)))) + (cond + (cached-dtd + (setf (dtd *ctx*) cached-dtd) + (report-cached-dtd cached-dtd)) + (t + (let ((xi2 (xstream-open-extid effective-extid))) + (with-zstream (zi2 :input-stack (list xi2)) + (ensure-dtd) + (p/ext-subset zi2) + (when (and fresh-dtd-p + *cache-all-dtds* + *validate* + (not (standalone-p *ctx*))) + (setf (getdtd sysid *dtd-cache*) (dtd *ctx*))))))))) + (sax:end-dtd (handler *ctx*)) + (let ((dtd (dtd *ctx*))) + (sax:entity-resolver + (handler *ctx*) + (lambda (name handler) (resolve-entity name handler dtd))) + (sax::dtd (handler *ctx*) dtd)) + (list :DOCTYPE name extid)))) + +(defun report-cached-dtd (dtd) + (maphash (lambda (k v) + (report-entity (handler *ctx*) :general k (cdr v))) + (dtd-gentities dtd)) + (maphash (lambda (k v) + (report-entity (handler *ctx*) :parameter k (cdr v))) + (dtd-pentities dtd)) + (maphash (lambda (k v) + (sax:notation-declaration + (handler *ctx*) + k + (if (extid-public v) + (normalize-public-id (extid-public v)) + nil) + (uri-rod (extid-system v)))) + (dtd-notations dtd))) + +(defun p/misc*-2 (input) + ;; Misc* + (while (member (peek-token input) '(:COMMENT :PI :S)) + (case (peek-token input) + (:COMMENT + (sax:comment (handler *ctx*) (nth-value 1 (peek-token input)))) + (:PI + (sax:processing-instruction + (handler *ctx*) + (car (nth-value 1 (peek-token input))) + (cdr (nth-value 1 (peek-token input)))))) + (consume-token input))) + +(defun p/document + (input handler + &key validate dtd root entity-resolver disallow-internal-subset + (recode t)) + ;; check types of user-supplied arguments for better error messages: + (check-type validate boolean) + (check-type recode boolean) + (check-type dtd (or null extid)) + (check-type root (or null rod)) + (check-type entity-resolver (or null function symbol)) + (check-type disallow-internal-subset boolean) + #+rune-is-integer + (when recode + (setf handler (make-recoder handler #'rod-to-utf8-string))) + (let* ((xstream (car (zstream-input-stack input))) + (name (xstream-name xstream)) + (base (when name (stream-name-uri name))) + (*ctx* + (make-context :handler handler + :main-zstream input + :entity-resolver entity-resolver + :base-stack (list (or base "")) + :disallow-internal-subset disallow-internal-subset)) + (*validate* validate) + (*namespace-bindings* *initial-namespace-bindings*)) + (sax:register-sax-parser handler (make-instance 'cxml-parser :ctx *ctx*)) + (sax:start-document handler) + ;; document ::= XMLDecl? Misc* (doctypedecl Misc*)? element Misc* + ;; Misc ::= Comment | PI | S + ;; xmldecl::='<?xml' VersionInfo EncodingDecl? SDDecl? S? '?>' + ;; sddecl::= S 'standalone' Eq (("'" ('yes' | 'no') "'") | ('"' ('yes' | 'no') '"')) + (let ((*data-behaviour* :DTD)) + ;; optional XMLDecl? + (p/xmldecl input) + ;; Misc* + (p/misc*-2 input) + ;; (doctypedecl Misc*)? + (cond + ((eq (peek-token input) :<!DOCTYPE) + (p/doctype-decl input dtd) + (p/misc*-2 input)) + (dtd + (synthesize-doctype dtd input)) + ((and validate (not dtd)) + (validity-error "invalid document: no doctype"))) + (ensure-dtd) + ;; Override expected root element if asked to + (when root + (setf (model-stack *ctx*) (list (make-root-model root)))) + ;; element + (let ((*data-behaviour* :DOC)) + (fix-seen-< input) + (p/element input)) + ;; optional Misc* + (p/misc*-2 input) + (p/eof input) + (sax:end-document handler)))) + +(defun synthesize-doctype (dtd input) + (let ((dummy (string->xstream "<!DOCTYPE dummy>"))) + (setf (xstream-name dummy) + (make-stream-name + :entity-name "dummy doctype" + :entity-kind :main + :uri (zstream-base-sysid input))) + (with-zstream (zstream :input-stack (list dummy)) + (p/doctype-decl zstream dtd)))) + +(defun fix-seen-< (input) + (when (eq (peek-token input) :seen-<) + (multiple-value-bind (c s) + (read-token-after-|<| input (car (zstream-input-stack input))) + (setf (zstream-token-category input) c + (zstream-token-semantic input) s)))) + +(defun p/xmldecl (input) + ;; we will use the attribute-value parser for the xml decl. + (prog1 + (when (eq (peek-token input) :xml-decl) + (let ((hd (parse-xml-decl (cdr (nth-value 1 (peek-token input)))))) + (setf (standalone-p *ctx*) (eq (xml-header-standalone-p hd) :yes)) + (setup-encoding input hd) + (read-token input) + hd)) + (set-full-speed input))) + +(defun p/eof (input) + (unless (eq (peek-token input) :eof) + (wf-error input "Garbage at end of document.")) + (when *validate* + (maphash (lambda (k v) + (unless v + (validity-error "(11) IDREF: ~S not defined" (rod-string k)))) + (id-table *ctx*)) + + (dolist (name (referenced-notations *ctx*)) + (unless (find-notation name (dtd *ctx*)) + (validity-error "(23) Notation Declared: ~S" (rod-string name)))))) + +(defun p/element (input) + (multiple-value-bind (cat n-b new-b uri lname qname attrs) (p/sztag input) + (sax:start-element (handler *ctx*) uri lname qname attrs) + (when (eq cat :stag) + (let ((*namespace-bindings* n-b)) + (p/content input)) + (p/etag input qname)) + (sax:end-element (handler *ctx*) uri lname qname) + (undeclare-namespaces new-b) + (pop (base-stack *ctx*)) + (validate-end-element *ctx* qname))) + +(defun p/sztag (input) + (multiple-value-bind (cat sem) (read-token input) + (case cat + ((:stag :ztag)) + (:eof (eox input)) + (t (wf-error input "element expected"))) + (destructuring-bind (&optional name &rest raw-attrs) sem + (validate-start-element *ctx* name) + (let* ((attrs + (process-attributes *ctx* name (build-attribute-list raw-attrs))) + (*namespace-bindings* *namespace-bindings*) + new-namespaces) + (when sax:*namespace-processing* + (setf new-namespaces (declare-namespaces attrs)) + (mapc #'set-attribute-namespace attrs)) + (push (compute-base attrs) (base-stack *ctx*)) + (multiple-value-bind (uri prefix local-name) + (if sax:*namespace-processing* + (decode-qname name) + (values nil nil nil)) + (declare (ignore prefix)) + (check-attribute-uniqueness attrs) + (unless (or sax:*include-xmlns-attributes* + (null sax:*namespace-processing*)) + (setf attrs + (remove-if (compose #'xmlns-attr-p #'sax:attribute-qname) + attrs))) + (values cat + *namespace-bindings* + new-namespaces + uri local-name name attrs)))))) + +(defun p/etag (input qname) + (multiple-value-bind (cat2 sem2) (read-token input) + (unless (and (eq cat2 :etag) + (eq (car sem2) qname)) + (wf-error input "Bad nesting. ~S / ~S" + (mu qname) + (mu (cons cat2 sem2)))) + (when (cdr sem2) + (wf-error input "no attributes allowed in end tag")))) + +;; copy&paste from cxml-rng +(defun escape-uri (string) + (with-output-to-string (out) + (loop for c across (cxml::rod-to-utf8-string string) do + (let ((code (char-code c))) + ;; http://www.w3.org/TR/xlink/#link-locators + (if (or (>= code 127) (<= code 32) (find c "<>\"{}|\\^`")) + (format out "%~2,'0X" code) + (write-char c out)))))) + +(defun compute-base (attrs) + (let ((new (sax:find-attribute #"xml:base" attrs)) + (current (car (base-stack *ctx*)))) + (if new + (puri:merge-uris (escape-uri (sax:attribute-value new)) current) + current))) + +(defun process-characters (input sem) + (consume-token input) + (when (search #"]]>" sem) + (wf-error input "']]>' not allowed in CharData")) + (validate-characters *ctx* sem)) + +(defun process-cdata-section (input) + (consume-token input) + (let ((input (car (zstream-input-stack input)))) + (unless (and (rune= #/C (read-rune input)) + (rune= #/D (read-rune input)) + (rune= #/A (read-rune input)) + (rune= #/T (read-rune input)) + (rune= #/A (read-rune input)) + (rune= #/\[ (read-rune input))) + (wf-error input "After '<![', 'CDATA[' is expected.")) + (validate-characters *ctx* #"hack") ;anything other than whitespace + (read-cdata-sect input))) + +(defun p/content (input) + ;; [43] content ::= (element | CharData | Reference | CDSect | PI | Comment)* + (multiple-value-bind (cat sem) (peek-token input) + (case cat + ((:stag :ztag) + (p/element input) + (p/content input)) + ((:CDATA) + (process-characters input sem) + (sax:characters (handler *ctx*) sem) + (p/content input)) + ((:ENTITY-REF) + (let ((name sem)) + (consume-token input) + (append + (recurse-on-entity input name :general + (lambda (input) + (prog1 + (etypecase (checked-get-entdef name :general) + (internal-entdef (p/content input)) + (external-entdef (p/ext-parsed-ent input))) + (unless (eq (peek-token input) :eof) + (wf-error input "Trailing garbage. - ~S" + (peek-token input)))))) + (p/content input)))) + ((:<!\[) + (let ((data (process-cdata-section input))) + (sax:start-cdata (handler *ctx*)) + (sax:characters (handler *ctx*) data) + (sax:end-cdata (handler *ctx*))) + (p/content input)) + ((:PI) + (consume-token input) + (sax:processing-instruction (handler *ctx*) (car sem) (cdr sem)) + (p/content input)) + ((:COMMENT) + (consume-token input) + (sax:comment (handler *ctx*) sem) + (p/content input)) + (otherwise + nil)))) + +;; [78] extParsedEnt ::= TextDecl? contentw +;; [79] extPE ::= TextDecl? extSubsetDecl + +(defstruct xml-header + version + encoding + (standalone-p nil)) + +(defun p/ext-parsed-ent (input) + ;; [78] extParsedEnt ::= '<?xml' VersionInfo? EncodingDecl S? '?>' content + (when (eq (peek-token input) :xml-decl) + (let ((hd (parse-text-decl (cdr (nth-value 1 (peek-token input)))))) + (setup-encoding input hd)) + (consume-token input)) + (set-full-speed input) + (p/content input)) + +(defun parse-xml-decl (content) + (let* ((res (make-xml-header)) + (i (make-rod-xstream content))) + (with-zstream (z :input-stack (list i)) + (let ((atts (read-attribute-list z i t))) + (unless (eq (peek-rune i) :eof) + (wf-error i "Garbage at end of XMLDecl.")) + ;; versioninfo muss da sein + ;; dann ? encodingdecl + ;; dann ? sddecl + ;; dann ende + (unless (eq (caar atts) (intern-name '#.(string-rod "version"))) + (wf-error i "XMLDecl needs version.")) + (unless (and (>= (length (cdar atts)) 1) + (every (lambda (x) + (or (rune<= #/a x #/z) + (rune<= #/A x #/Z) + (rune<= #/0 x #/9) + (rune= x #/_) + (rune= x #/.) + (rune= x #/:) + (rune= x #/-))) + (cdar atts))) + (wf-error i"Bad XML version number: ~S." (rod-string (cdar atts)))) + (setf (xml-header-version res) (rod-string (cdar atts))) + (pop atts) + (when (eq (caar atts) (intern-name '#.(string-rod "encoding"))) + (unless (and (>= (length (cdar atts)) 1) + (every (lambda (x) + (or (rune<= #/a x #/z) + (rune<= #/A x #/Z) + (rune<= #/0 x #/9) + (rune= x #/_) + (rune= x #/.) + (rune= x #/-))) + (cdar atts)) + ((lambda (x) + (or (rune<= #/a x #/z) + (rune<= #/A x #/Z))) + (aref (cdar atts) 0))) + (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts)))) + (setf (xml-header-encoding res) (rod-string (cdar atts))) + (pop atts)) + (when (eq (caar atts) (intern-name '#.(string-rod "standalone"))) + (unless (or (rod= (cdar atts) '#.(string-rod "yes")) + (rod= (cdar atts) '#.(string-rod "no"))) + (wf-error i "XMLDecl's 'standalone' attribute must be exactly \"yes\" or \"no\" and not ~S." + (rod-string (cdar atts)))) + (setf (xml-header-standalone-p res) + (if (rod-equal '#.(string-rod "yes") (cdar atts)) + :yes + :no)) + (pop atts)) + (when atts + (wf-error i "Garbage in XMLDecl: ~A" (rod-string content))) + res)))) + +(defun parse-text-decl (content) + (let* ((res (make-xml-header)) + (i (make-rod-xstream content))) + (with-zstream (z :input-stack (list i)) + (let ((atts (read-attribute-list z i t))) + (unless (eq (peek-rune i) :eof) + (wf-error i "Garbage at end of TextDecl")) + ;; versioninfo optional + ;; encodingdecl muss da sein + ;; dann ende + (when (eq (caar atts) (intern-name '#.(string-rod "version"))) + (unless (and (>= (length (cdar atts)) 1) + (every (lambda (x) + (or (rune<= #/a x #/z) + (rune<= #/A x #/Z) + (rune<= #/0 x #/9) + (rune= x #/_) + (rune= x #/.) + (rune= x #/:) + (rune= x #/-))) + (cdar atts))) + (wf-error i "Bad XML version number: ~S." (rod-string (cdar atts)))) + (setf (xml-header-version res) (rod-string (cdar atts))) + (pop atts)) + (unless (eq (caar atts) (intern-name '#.(string-rod "encoding"))) + (wf-error i "TextDecl needs encoding.")) + (unless (and (>= (length (cdar atts)) 1) + (every (lambda (x) + (or (rune<= #/a x #/z) + (rune<= #/A x #/Z) + (rune<= #/0 x #/9) + (rune= x #/_) + (rune= x #/.) + (rune= x #/-))) + (cdar atts)) + ((lambda (x) + (or (rune<= #/a x #/z) + (rune<= #/A x #/Z) + (rune<= #/0 x #/9))) + (aref (cdar atts) 0))) + (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts)))) + (setf (xml-header-encoding res) (rod-string (cdar atts))) + (pop atts) + (when atts + (wf-error i "Garbage in TextDecl: ~A" (rod-string content))))) + res)) + +;;;; --------------------------------------------------------------------------- +;;;; mu +;;;; + +(defun mu (x) + (cond ((stringp x) x) + ((vectorp x) (rod-string x)) + ((consp x) + (cons (mu (car x)) (mu (cdr x)))) + (x))) + +;;;; --------------------------------------------------------------------------- +;;;; User interface ;;;; + +#-cxml-system::uri-is-namestring +(defun specific-or (component &optional (alternative nil)) + (if (eq component :unspecific) + alternative + component)) + +(defun string-or (str &optional (alternative nil)) + (if (zerop (length str)) + alternative + str)) + +#-cxml-system::uri-is-namestring +(defun make-uri (&rest initargs &key path query &allow-other-keys) + (apply #'make-instance + 'puri:uri + :path (and path (escape-path path)) + :query (and query (escape-query query)) + initargs)) + +#-cxml-system::uri-is-namestring +(defun escape-path (list) + (puri::render-parsed-path list t)) + +#-cxml-system::uri-is-namestring +(defun escape-query (pairs) + (flet ((escape (str) + (puri::encode-escaped-encoding str puri::*reserved-characters* t))) + (let ((first t)) + (with-output-to-string (s) + (dolist (pair pairs) + (if first + (setf first nil) + (write-char #\& s)) + (write-string (escape (car pair)) s) + (write-char #\= s) + (write-string (escape (cdr pair)) s)))))) + +#-cxml-system::uri-is-namestring +(defun uri-parsed-query (uri) + (flet ((unescape (str) + (puri::decode-escaped-encoding str t puri::*reserved-characters*))) + (let ((str (puri:uri-query uri))) + (cond + (str + (let ((pairs '())) + (dolist (s (split-sequence-if (lambda (x) (eql x #\&)) str)) + (destructuring-bind (name value) + (split-sequence-if (lambda (x) (eql x #\=)) s) + (push (cons (unescape name) (unescape value)) pairs))) + (reverse pairs))) + (t + nil))))) + +#-cxml-system::uri-is-namestring +(defun query-value (name alist) + (cdr (assoc name alist :test #'equal))) + +#-cxml-system::uri-is-namestring +(defun pathname-to-uri (pathname) + (let ((path + (append (pathname-directory pathname) + (list + (if (specific-or (pathname-type pathname)) + (concatenate 'string + (pathname-name pathname) + "." + (pathname-type pathname)) + (pathname-name pathname)))))) + (if (eq (car path) :relative) + (make-uri :path path) + (make-uri :scheme :file + :host (concatenate 'string + (string-or (host-namestring pathname)) + "+" + (specific-or (pathname-device pathname))) + :path path)))) + +#+cxml-system::uri-is-namestring +(defun pathname-to-uri (pathname) + (puri:parse-uri (namestring pathname))) + +#-cxml-system::uri-is-namestring +(defun parse-name.type (str) + (if str + (let ((i (position #\. str :from-end t))) + (if i + (values (subseq str 0 i) (subseq str (1+ i))) + (values str nil))) + (values nil nil))) + +#-cxml-system::uri-is-namestring +(defun uri-to-pathname (uri) + (let ((scheme (puri:uri-scheme uri)) + (path (puri:uri-parsed-path uri))) + (unless (member scheme '(nil :file)) + (error 'xml-parse-error + :format-control "URI scheme ~S not supported" + :format-arguments (list scheme))) + (if (eq (car path) :relative) + (multiple-value-bind (name type) + (parse-name.type (car (last path))) + (make-pathname :directory (butlast path) + :name name + :type type)) + (multiple-value-bind (name type) + (parse-name.type (car (last (cdr path)))) + (destructuring-bind (host device) + (split-sequence-if (lambda (x) (eql x #\+)) + (or (puri:uri-host uri) "+")) + (make-pathname :host (string-or host) + :device (string-or device) + :directory (cons :absolute (butlast (cdr path))) + :name name + :type type)))))) +#+cxml-system::uri-is-namestring +(defun uri-to-pathname (uri) + (let ((pathname (puri:render-uri uri nil))) + (when (equalp (pathname-host pathname) "+") + (setf (slot-value pathname 'lisp::host) "localhost")) + pathname)) + +(defun parse + (input handler &rest args + &key validate dtd root entity-resolver disallow-internal-subset + recode pathname) + (declare (ignore validate dtd root entity-resolver disallow-internal-subset + recode)) + (let ((args + (loop + for (name value) on args by #'cddr + unless (eq name :pathname) + append (list name value)))) + (etypecase input + (xstream (apply #'make-xstream input handler args)) + (pathname (apply #'parse-file input handler args)) + (rod (apply #'parse-rod input handler args)) + (array (apply #'parse-octets input handler args)) + (stream + (let ((xstream (make-xstream input :speed 8192))) + (setf (xstream-name xstream) + (make-stream-name + :entity-name "main document" + :entity-kind :main + :uri (pathname-to-uri + (merge-pathnames (or pathname (pathname input)))))) + (apply #'parse-xstream xstream handler args)))))) + +(defun parse-xstream (xstream handler &rest args) + (let ((*ctx* nil)) + (handler-case + (with-zstream (zstream :input-stack (list xstream)) + (peek-rune xstream) + (with-scratch-pads () + (apply #'p/document zstream handler args))) + (runes-encoding:encoding-error (c) + (wf-error xstream "~A" c))))) + +(defun parse-file (filename handler &rest args) + (with-open-xfile (input filename) + (setf (xstream-name input) + (make-stream-name + :entity-name "main document" + :entity-kind :main + :uri (pathname-to-uri (merge-pathnames filename)))) + (apply #'parse-xstream input handler args))) + +(defun resolve-synonym-stream (stream) + (while (typep stream 'synonym-stream) + (setf stream (symbol-value (synonym-stream-symbol stream)))) + stream) + +(defun safe-stream-sysid (stream) + (if (and (typep (resolve-synonym-stream stream) 'file-stream) + ;; ignore-errors, because sb-bsd-sockets creates instances of + ;; FILE-STREAMs that aren't + (ignore-errors (pathname stream))) + (pathname-to-uri (merge-pathnames (pathname stream))) + nil)) + +(defun parse-stream (stream handler &rest args) + (let ((xstream + (make-xstream + stream + :name (make-stream-name + :entity-name "main document" + :entity-kind :main + :uri (safe-stream-sysid stream)) + :initial-speed 1))) + (apply #'parse-xstream xstream handler args))) + +(defun parse-empty-document + (uri qname handler &key public-id system-id entity-resolver (recode t)) + (check-type uri (or null rod)) + (check-type qname (or null rod)) + (check-type public-id (or null rod)) + (check-type system-id (or null puri:uri)) + (check-type entity-resolver (or null function symbol)) + (check-type recode boolean) + #+rune-is-integer + (when recode + (setf handler (make-recoder handler #'rod-to-utf8-string))) + (let ((*ctx* + (make-context :handler handler :entity-resolver entity-resolver)) + (*validate* nil) + (extid + (when (or public-id system-id) + (extid-using-catalog (make-extid public-id system-id))))) + (sax:start-document handler) + (when extid + (sax:start-dtd handler + qname + (and public-id) + (and system-id (uri-rod system-id))) + (setf (dtd *ctx*) (getdtd (extid-system extid) *dtd-cache*)) + (unless (dtd *ctx*) + (with-scratch-pads () + (let ((*data-behaviour* :DTD)) + (let ((xi2 (xstream-open-extid extid))) + (with-zstream (zi2 :input-stack (list xi2)) + (ensure-dtd) + (p/ext-subset zi2)))))) + (sax:end-dtd handler) + (let ((dtd (dtd *ctx*))) + (sax:entity-resolver handler (lambda (n h) (resolve-entity n h dtd))) + (sax::dtd handler dtd))) + (ensure-dtd) + (when (or uri qname) + (let* ((attrs + (when uri + (list (sax:make-attribute :qname #"xmlns" + :value (rod uri) + :specified-p t)))) + (*namespace-bindings* *namespace-bindings*) + new-namespaces) + (when sax:*namespace-processing* + (setf new-namespaces (declare-namespaces attrs)) + (mapc #'set-attribute-namespace attrs)) + (multiple-value-bind (uri prefix local-name) + (if sax:*namespace-processing* (decode-qname qname) nil) + (declare (ignore prefix)) + (unless (or sax:*include-xmlns-attributes* + (null sax:*namespace-processing*)) + (setf attrs nil)) + (sax:start-element (handler *ctx*) uri local-name qname attrs) + (sax:end-element (handler *ctx*) uri local-name qname)) + (undeclare-namespaces new-namespaces))) + (sax:end-document handler))) + +(defun parse-dtd-file (filename &optional handler) + (with-open-file (s filename :element-type '(unsigned-byte 8)) + (parse-dtd-stream s handler))) + +(defun parse-dtd-stream (stream &optional handler) + (let ((input (make-xstream stream))) + (setf (xstream-name input) + (make-stream-name + :entity-name "dtd" + :entity-kind :main + :uri (safe-stream-sysid stream))) + (let ((*ctx* (make-context :handler handler)) + (*validate* t) + (*data-behaviour* :DTD)) + (with-zstream (zstream :input-stack (list input)) + (with-scratch-pads () + (ensure-dtd) + (peek-rune input) + (p/ext-subset zstream) + (dtd *ctx*)))))) + +(defun parse-rod (string handler &rest args) + (let ((xstream (string->xstream string))) + (setf (xstream-name xstream) + (make-stream-name + :entity-name "main document" + :entity-kind :main + :uri nil)) + (apply #'parse-xstream xstream handler args))) + +(defun string->xstream (string) + (make-rod-xstream (string-rod string))) + +(defun parse-octets (octets handler &rest args) + (apply #'parse-stream (make-octet-input-stream octets) handler args)) + +;;;; + +(defun zstream-push (new-xstream zstream) + (cond ((find-if (lambda (x) + (and (xstream-p x) + (eql (stream-name-entity-name (xstream-name x)) + (stream-name-entity-name (xstream-name new-xstream))) + (eql (stream-name-entity-kind (xstream-name x)) + (stream-name-entity-kind (xstream-name new-xstream))))) + (zstream-input-stack zstream)) + (wf-error zstream "Infinite recursion."))) + (push new-xstream (zstream-input-stack zstream)) + zstream) + +(defun recurse-on-entity (zstream name kind continuation &optional internalp) + (assert (not (zstream-token-category zstream))) + (call-with-entity-expansion-as-stream + zstream + (lambda (new-xstream) + (push :stop (zstream-input-stack zstream)) + (zstream-push new-xstream zstream) + (prog1 + (funcall continuation zstream) + (assert (eq (peek-token zstream) :eof)) + (assert (eq (pop (zstream-input-stack zstream)) new-xstream)) + (close-xstream new-xstream) + (assert (eq (pop (zstream-input-stack zstream)) :stop)) + (setf (zstream-token-category zstream) nil) + '(consume-token zstream)) ) + name + kind + internalp)) + +#|| +(defmacro read-data-until* ((predicate input res res-start res-end) &body body) + ;; fast variant -- for now disabled for no apparent reason + ;; -> res, res-start, res-end + `(let* ((rptr (xstream-read-ptr ,input)) + (p0 rptr) + (fptr (xstream-fill-ptr ,input)) + (buf (xstream-buffer ,input)) + ,res ,res-start ,res-end) + (declare (type fixnum rptr fptr p0) + (type (simple-array read-element (*)) buf)) + (loop + (cond ((%= rptr fptr) + ;; underflow -- hmm inject the scratch-pad with what we + ;; read and continue, while using read-rune and collecting + ;; d.h. besser waere hier auch while-reading zu benutzen. + (setf (xstream-read-ptr ,input) rptr) + (multiple-value-setq (,res ,res-start ,res-end) + (with-rune-collector/raw (collect) + (do ((i p0 (%+ i 1))) + ((%= i rptr)) + (collect (%rune buf i))) + (let (c) + (loop + (cond ((%= rptr fptr) + (setf (xstream-read-ptr ,input) rptr) + (setf c (peek-rune input)) + (cond ((eq c :eof) + (return))) + (setf rptr (xstream-read-ptr ,input) + fptr (xstream-fill-ptr ,input) + buf (xstream-buffer ,input))) + (t + (setf c (%rune buf rptr)))) + (cond ((,predicate c) + ;; we stop + (setf (xstream-read-ptr ,input) rptr) + (return)) + (t + ;; we continue + (collect c) + (setf rptr (%+ rptr 1))) ))))) + (return)) + ((,predicate (%rune buf rptr)) + ;; we stop + (setf (xstream-read-ptr ,input) rptr) + (setf ,res buf ,res-start p0 ,res-end rptr) + (return) ) + (t + we continue + (sf rptr (%+ rptr 1))) )) + ,@body )) +||# + +(defmacro read-data-until* ((predicate input res res-start res-end) &body body) + "Read data from `input' until `predicate' applied to the read char + turns true. Then execute `body' with `res', `res-start', `res-end' + bound to denote a subsequence (of RUNEs) containing the read portion. + The rune upon which `predicate' turned true is neither consumed from + the stream, nor included in `res'. + + Keep the predicate short, this it may be included more than once into + the macro's expansion." + ;; + (let ((input-var (gensym)) + (collect (gensym)) + (c (gensym))) + `(LET ((,input-var ,input)) + (MULTIPLE-VALUE-BIND (,res ,res-start ,res-end) + (WITH-RUNE-COLLECTOR/RAW (,collect) + (LOOP + (LET ((,c (PEEK-RUNE ,input-var))) + (COND ((EQ ,c :EOF) + ;; xxx error message + (RETURN)) + ((FUNCALL ,predicate ,c) + (RETURN)) + (t + (,collect ,c) + (CONSUME-RUNE ,input-var)))))) + (LOCALLY + ,@body))))) + +(defun read-name-token (input) + (read-data-until* ((lambda (rune) + (declare (type rune rune)) + (not (name-rune-p rune))) + input + r rs re) + (intern-name r rs re))) + +(defun read-cdata (input) + (read-data-until* ((lambda (rune) + (declare (type rune rune)) + (when (and (%rune< rune #/U+0020) + (not (or (%rune= rune #/U+0009) + (%rune= rune #/U+000a) + (%rune= rune #/U+000d)))) + (wf-error input "code point invalid: ~A" rune)) + (or (%rune= rune #/<) (%rune= rune #/&))) + input + source start end) + (locally + (declare (type (simple-array rune (*)) source) + (type ufixnum start) + (type ufixnum end) + (optimize (speed 3) (safety 0))) + (let ((res (make-array (%- end start) :element-type 'rune))) + (declare (type (simple-array rune (*)) res)) + (let ((i (%- end start))) + (declare (type ufixnum i)) + (loop + (setf i (- i 1)) + (setf (%rune res i) (%rune source (the ufixnum (+ i start)))) + (when (= i 0) + (return)))) + res)))) + +;; used only by read-att-value-2 +(defun internal-entity-expansion (name) + (let ((def (get-entity-definition name :general (dtd *ctx*)))) + (unless def + (wf-error nil "Entity '~A' is not defined." (rod-string name))) + (unless (typep def 'internal-entdef) + (wf-error nil "Entity '~A' is not an internal entity." name)) + (or (entdef-expansion def) + (setf (entdef-expansion def) (find-internal-entity-expansion name))))) + +;; used only by read-att-value-2 +(defun find-internal-entity-expansion (name) + (with-zstream (zinput) + (with-rune-collector-3 (collect) + (labels ((muffle (input) + (let (c) + (loop + (setf c (read-rune input)) + (cond ((eq c :eof) + (return)) + ((rune= c #/&) + (setf c (peek-rune input)) + (cond ((eql c :eof) + (eox input)) + ((rune= c #/#) + (let ((c (read-character-reference input))) + (%put-unicode-char c collect))) + (t + (unless (name-start-rune-p c) + (wf-error zinput "Expecting name after &.")) + (let ((name (read-name-token input))) + (setf c (read-rune input)) + (check-rune input c #/\;) + (recurse-on-entity + zinput name :general + (lambda (zinput) + (muffle (car (zstream-input-stack zinput))))))))) + ((rune= c #/<) + (wf-error zinput "unexpected #\/<")) + ((space-rune-p c) + (collect #/space)) + ((not (data-rune-p c)) + (wf-error zinput "illegal char: ~S." c)) + (t + (collect c))))))) + (declare (dynamic-extent #'muffle)) + (recurse-on-entity + zinput name :general + (lambda (zinput) + (muffle (car (zstream-input-stack zinput))))))))) + +;; callback for DOM +(defun resolve-entity (name handler dtd) + (let ((*validate* nil)) + (if (get-entity-definition name :general dtd) + (let* ((*ctx* (make-context :handler handler :dtd dtd)) + (*data-behaviour* :DOC)) + (with-zstream (input) + (with-scratch-pads () + (recurse-on-entity + input name :general + (lambda (input) + (prog1 + (etypecase (checked-get-entdef name :general) + (internal-entdef (p/content input)) + (external-entdef (p/ext-parsed-ent input))) + (unless (eq (peek-token input) :eof) + (wf-error input "Trailing garbage. - ~S" + (peek-token input))))))))) + nil))) + +(defun read-att-value-2 (input) + (let ((delim (read-rune input))) + (when (eql delim :eof) + (eox input)) + (unless (member delim '(#/\" #/\') :test #'eql) + (wf-error input + "Bad attribute value delimiter ~S, must be either #\\\" or #\\\'." + (rune-char delim))) + (with-rune-collector-4 (collect) + (loop + (let ((c (read-rune input))) + (cond ((eq c :eof) + (eox input "EOF")) + ((rune= c delim) + (return)) + ((rune= c #/<) + (wf-error input "'<' not allowed in attribute values")) + ((rune= #/& c) + (multiple-value-bind (kind sem) (read-entity-like input) + (ecase kind + (:CHARACTER-REFERENCE + (%put-unicode-char sem collect)) + (:ENTITY-REFERENCE + (let* ((exp (internal-entity-expansion sem)) + (n (length exp))) + (declare (type (simple-array rune (*)) exp)) + (do ((i 0 (%+ i 1))) + ((%= i n)) + (collect (%rune exp i)))))))) + ((space-rune-p c) + (collect #/u+0020)) + (t + (collect c)))))))) + +;;;;;;;;;;;;;;;;; + +;;; Namespace stuff + +;; We already know that name is part of a valid XML name, so all we +;; have to check is that the first rune is a name-start-rune and that +;; there is not colon in it. +(defun nc-name-p (name) + (and (plusp (length name)) + (name-start-rune-p (rune name 0)) + (notany #'(lambda (rune) (rune= #/: rune)) name))) + +(defun split-qname (qname) + (declare (type runes:simple-rod qname)) + (let ((pos (position #/: qname))) + (if pos + (let ((prefix (subseq qname 0 pos)) + (local-name (subseq qname (1+ pos)))) + (when (zerop pos) + (wf-error nil "empty namespace prefix")) + (if (nc-name-p local-name) + (values prefix local-name) + (wf-error nil "~S is not a valid NcName." + (rod-string local-name)))) + (values () qname)))) + +(defun decode-qname (qname) + "decode-qname name => namespace-uri, prefix, local-name" + (declare (type runes:simple-rod qname)) + (multiple-value-bind (prefix local-name) (split-qname qname) + (let ((uri (find-namespace-binding prefix))) + (if uri + (values uri prefix local-name) + (values nil nil qname))))) + + +(defun find-namespace-binding (prefix) + (cdr (or (assoc (or prefix #"") *namespace-bindings* :test #'rod=) + (wf-error nil "Undeclared namespace prefix: ~A" (rod-string prefix))))) + +;; FIXME: Should probably be refactored by adding :start and :end to rod=/rod-equal +(defun rod-starts-with (prefix rod) + (and (<= (length prefix) (length rod)) + (dotimes (i (length prefix) t) + (unless (rune= (rune prefix i) (rune rod i)) + (return nil))))) + +(defun xmlns-attr-p (attr-name) + (rod-starts-with #.(string-rod "xmlns") attr-name)) + +(defun attrname->prefix (attrname) + (if (< 5 (length attrname)) + (subseq attrname 6) + nil)) + +(defun find-namespace-declarations (attributes) + (loop + for attribute in attributes + for qname = (sax:attribute-qname attribute) + when (xmlns-attr-p qname) + collect (cons (attrname->prefix qname) (sax:attribute-value attribute)))) + +(defun declare-namespaces (attributes) + (let ((ns-decls (find-namespace-declarations attributes))) + (dolist (ns-decl ns-decls) + ;; check some namespace validity constraints + (let ((prefix (car ns-decl)) + (uri (cdr ns-decl))) + (cond + ((and (rod= prefix #"xml") + (not (rod= uri #"http://www.w3.org/XML/1998/namespace"))) + (wf-error nil + "Attempt to rebind the prefix \"xml\" to ~S." (mu uri))) + ((and (rod= uri #"http://www.w3.org/XML/1998/namespace") + (not (rod= prefix #"xml"))) + (wf-error nil + "The namespace ~ + URI \"http://www.w3.org/XML/1998/namespace\" may not ~ + be bound to the prefix ~S, only \"xml\" is legal." + (mu prefix))) + ((and (rod= prefix #"xmlns") + (rod= uri #"http://www.w3.org/2000/xmlns/")) + (wf-error nil + "Attempt to bind the prefix \"xmlns\" to its predefined ~ + URI \"http://www.w3.org/2000/xmlns/\", which is ~ + forbidden for no good reason.")) + ((rod= prefix #"xmlns") + (wf-error nil + "Attempt to bind the prefix \"xmlns\" to the URI ~S, ~ + but it may not be declared." (mu uri))) + ((rod= uri #"http://www.w3.org/2000/xmlns/") + (wf-error nil + "The namespace URI \"http://www.w3.org/2000/xmlns/\" may ~ + not be bound to prefix ~S (or any other)." (mu prefix))) + ((and (rod= uri #"") prefix) + (wf-error nil + "Only the default namespace (the one without a prefix) ~ + may be bound to an empty namespace URI, thus ~ + undeclaring it.")) + (t + (push (cons prefix (if (rod= #"" uri) nil uri)) + *namespace-bindings*) + (sax:start-prefix-mapping (handler *ctx*) + (car ns-decl) + (cdr ns-decl)))))) + ns-decls)) + +(defun undeclare-namespaces (ns-decls) + (dolist (ns-decl ns-decls) + (sax:end-prefix-mapping (handler *ctx*) (car ns-decl)))) + +(defun build-attribute-list (attr-alist) + ;; fixme: if there is a reason this function reverses attribute order, + ;; it should be documented. + (let (attributes) + (dolist (pair attr-alist) + (push (sax:make-attribute :qname (car pair) + :value (cdr pair) + :specified-p t) + attributes)) + attributes)) + +(defun check-attribute-uniqueness (attributes) + ;; 5.3 Uniqueness of Attributes + ;; In XML documents conforming to [the xmlns] specification, no + ;; tag may contain two attributes which: + ;; 1. have identical names, or + ;; 2. have qualified names with the same local part and with + ;; prefixes which have been bound to namespace names that are + ;; identical. + ;; + ;; 1. is checked by read-tag-2, so we only deal with 2 here + (loop for (attr-1 . rest) on attributes do + (when (and (sax:attribute-namespace-uri attr-1) + (find-if (lambda (attr-2) + (and (rod= (sax:attribute-namespace-uri attr-1) + (sax:attribute-namespace-uri attr-2)) + (rod= (sax:attribute-local-name attr-1) + (sax:attribute-local-name attr-2)))) + rest)) + (wf-error nil + "Multiple definitions of attribute ~S in namespace ~S." + (mu (sax:attribute-local-name attr-1)) + (mu (sax:attribute-namespace-uri attr-1)))))) + +(defun set-attribute-namespace (attribute) + (let ((qname (sax:attribute-qname attribute))) + (if (and sax:*use-xmlns-namespace* (rod= qname #"xmlns")) + (setf (sax:attribute-namespace-uri attribute) + #"http://www.w3.org/2000/xmlns/") + (multiple-value-bind (prefix local-name) (split-qname qname) + (when (and prefix ;; default namespace doesn't apply to attributes + (or (not (rod= #"xmlns" prefix)) + sax:*use-xmlns-namespace*)) + (setf (sax:attribute-namespace-uri attribute) + (decode-qname qname))) + (setf (sax:attribute-local-name attribute) local-name))))) + +;;;;;;;;;;;;;;;;; + +;; System Identifier Protocol + +;; A system identifier is an object obeying to the system identifier +;; protocol. Often something like an URL or a pathname. + +;; OPEN-SYS-ID sys-id [generic function] +;; +;; Opens the resource associated with the system identifier `sys-id' +;; for reading and returns a stream. For now it is expected, that the +;; stream is an octet stream (one of element type (unsigned-byte 8)). +;; +;; More precisely: The returned object only has to obey to the xstream +;; controller protocol. (That is it has to provide implementations for +;; READ-OCTETS and XSTREAM-CONTROLLER-CLOSE). + +;; MERGE-SYS-ID sys-id base [generic function] +;; +;; Merges two system identifiers. That is resolve `sys-id' relative to +;; `base' yielding an absolute system identifier suitable for +;; OPEN-SYS-ID. + + +;;;;;;;;;;;;;;;;; +;;; SAX validation handler + +(defclass validator () + ((context :initarg :context :accessor context) + (cdatap :initform nil :accessor cdatap))) + +(defun make-validator (dtd root) + (make-instance 'validator + :context (make-context + :handler nil + :dtd dtd + :model-stack (list (make-root-model root))))) + +(macrolet ((with-context ((validator) &body body) + `(let ((*ctx* (context ,validator)) + (*validate* t)) + (with-scratch-pads () ;nicht schoen + ,@body)))) + (defmethod sax:start-element ((handler validator) uri lname qname attributes) + uri lname + (with-context (handler) + (validate-start-element *ctx* qname) + (process-attributes *ctx* qname attributes))) + + (defmethod sax:start-cdata ((handler validator)) + (setf (cdatap handler) t)) + + (defmethod sax:characters ((handler validator) data) + (with-context (handler) + (validate-characters *ctx* (if (cdatap handler) #"hack" data)))) + + (defmethod sax:end-cdata ((handler validator)) + (setf (cdatap handler) nil)) + + (defmethod sax:end-element ((handler validator) uri lname qname) + uri lname + (with-context (handler) + (validate-end-element *ctx* qname)))) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xmlns-normalizer.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xmlns-normalizer.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xmlns-normalizer.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,136 @@ +;;;; xmlns-normalizer.lisp -- DOM 3-style namespace normalization +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Copyright (c) 2005 David Lichteblau + +;;;; Hier eine Variante des reichlich furchtbaren Algorithmus zur +;;;; Namespace-Normalisierung aus DOM 3 Core.[1] +;;;; +;;;; Gebraucht wir die Sache, weil Element- und Attributknoten in DOM +;;;; zwar ein Prefix-Attribut speichern, massgeblich fuer ihren Namespace +;;;; aber nur die URI sein soll. Und eine Anpassung der zugehoerigen +;;;; xmlns-Attribute findet bei Veraenderungen im DOM-Baum nicht statt, +;;;; bzw. wird dem Nutzer ueberlassen. +;;;; +;;;; Daher muss letztlich spaetestens beim Serialisieren eine +;;;; Namespace-Deklaration fuer die angegebene URI nachgetragen und das +;;;; Praefix ggf. umbenannt werden, damit am Ende doch etwas +;;;; Namespace-konformes heraus kommt. +;;;; +;;;; Und das nennen sie dann Namespace-Support. +;;;; +;;;; [1] http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/namespaces-algorith… + +(in-package :cxml) + +(defclass namespace-normalizer (sax-proxy) + ((xmlns-stack :initarg :xmlns-stack :accessor xmlns-stack))) + +(defvar *xmlns-namespace* #"http://www.w3.org/2000/xmlns/") + +(defun make-namespace-normalizer (chained-handler) + (make-instance 'namespace-normalizer + :xmlns-stack (list (mapcar (lambda (cons) + (make-xmlns-attribute (car cons) (cdr cons))) + *initial-namespace-bindings*)) + :chained-handler chained-handler)) + +(defun normalizer-find-prefix (handler prefix) + (when (zerop (length prefix)) + (setf prefix #"xmlns")) + (block t + (dolist (bindings (xmlns-stack handler)) + (dolist (attribute bindings) + (when (rod= (sax:attribute-local-name attribute) prefix) + (return-from t attribute)))))) + +(defun normalizer-find-uri (handler uri) + (block t + (dolist (bindings (xmlns-stack handler)) + (dolist (attribute bindings) + (when (and (rod= (sax:attribute-value attribute) uri) + ;; default-namespace interessiert uns nicht + (not (rod= (sax:attribute-qname attribute) #"xmlns"))) + (return-from t attribute)))))) + +(defun make-xmlns-attribute (prefix uri) + (if (and (plusp (length prefix)) (not (equal prefix #"xmlns"))) + (sax:make-attribute + :qname (concatenate 'rod #"xmlns:" prefix) + :namespace-uri *xmlns-namespace* + :local-name prefix + :value uri) + (sax:make-attribute + :qname #"xmlns" + :namespace-uri *xmlns-namespace* + :local-name #"xmlns" + :value uri))) + +(defun rename-attribute (a new-prefix) + (setf (sax:attribute-qname a) + (concatenate 'rod new-prefix #":" (sax:attribute-local-name a)))) + +(defmethod sax:start-element + ((handler namespace-normalizer) uri lname qname attrs) + (when (null uri) + (setf uri #"")) + (let ((normal-attrs '())) + (push nil (xmlns-stack handler)) + (dolist (a attrs) + (if (rod= *xmlns-namespace* (sax:attribute-namespace-uri a)) + (push a (car (xmlns-stack handler))) + (push a normal-attrs))) + (flet ((push-namespace (prefix uri) + (let ((new (make-xmlns-attribute prefix uri))) + (unless (find (sax:attribute-qname new) + attrs + :test #'rod= + :key #'sax:attribute-qname) + (push new (car (xmlns-stack handler))) + (push new attrs))))) + (multiple-value-bind (prefix local-name) (split-qname qname) + (setf lname local-name) + (let ((binding (normalizer-find-prefix handler prefix))) + (cond + ((null binding) + (unless (and (null prefix) (zerop (length uri))) + (push-namespace prefix uri))) + ((rod= (sax:attribute-value binding) uri)) + ((member binding (car (xmlns-stack handler))) + (setf (sax:attribute-value binding) uri)) + (t + (push-namespace prefix uri))))) + (dolist (a normal-attrs) + (let ((u (sax:attribute-namespace-uri a))) + (when u + (let* ((prefix (split-qname (sax:attribute-qname a))) + (prefix-binding + (when prefix + (normalizer-find-prefix handler prefix)))) + (when (or (null prefix-binding) + (not (rod= (sax:attribute-value prefix-binding) u))) + (let ((uri-binding (normalizer-find-uri handler u))) + (cond + (uri-binding + (rename-attribute + a + (sax:attribute-local-name uri-binding))) + ((and prefix (null prefix-binding)) + (push-namespace prefix u)) + (t + (loop + for i from 1 + for prefix = (rod (format nil "NS~D" i)) + unless (normalizer-find-prefix handler prefix) + do + (push-namespace prefix u) + (rename-attribute a prefix) + (return)))))))))))) + (sax:start-element (proxy-chained-handler handler) uri lname qname attrs)) + +(defmethod sax:end-element ((handler namespace-normalizer) uri lname qname) + (declare (ignore qname)) + (pop (xmlns-stack handler)) + (sax:end-element (proxy-chained-handler handler) (or uri #"") lname qname)) Added: branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xmls-compat.lisp =================================================================== --- branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xmls-compat.lisp 2007-10-04 19:02:16 UTC (rev 2202) +++ branches/trunk-reorg/thirdparty/cxml-2007-08-05/xml/xmls-compat.lisp 2007-10-04 19:03:03 UTC (rev 2203) @@ -0,0 +1,243 @@ +;;;; xml-compat.lisp -- XMLS-compatible data structures +;;;; +;;;; This file is part of the CXML parser, released under Lisp-LGPL. +;;;; See file COPYING for details. +;;;; +;;;; Developed 2004 for headcraft - http://headcraft.de/ +;;;; Copyright: David Lichteblau + +(defpackage cxml-xmls + (:use :cl :runes) + (:export #:make-node #:node-name #:node-ns #:node-attrs #:node-children + #:make-xmls-builder #:map-node)) + +(in-package :cxml-xmls) + + +;;;; Knoten + +(defun make-node (&key name ns attrs children) + `(,(if ns (cons name ns) name) + ,attrs + ,@children)) + +(defun node-name (node) + (let ((car (car node))) + (if (consp car) + (car car) + car))) + +(defun (setf node-name) (newval node) + (let ((car (car node))) + (if (consp car) + (setf (car car) newval) + (setf (car node) newval)))) + +(defun node-ns (node) + (let ((car (car node))) + (if (consp car) + (cdr car) + nil))) + +(defun (setf node-ns) (newval node) + (let ((car (car node))) + (if (consp car) + (setf (cdr car) newval) + (setf (car node) (cons car newval))) + newval)) + +(defun node-attrs (node) + (cadr node)) + +(defun (setf node-attrs) (newval node) + (setf (cadr node) newval)) + +(defun node-children (node) + (cddr node)) + +(defun (setf node-children) (newval node) + (setf (cddr node) newval)) + + +;;;; SAX-Handler (Parser) + +(defclass xmls-builder () + ((element-stack :initform nil :accessor element-stack) + (root :initform nil :accessor root) + (include-default-values :initform t + :initarg :include-default-values + :accessor include-default-values) + (include-namespace-uri :initform t + :initarg :include-namespace-uri + :accessor include-namespace-uri))) + +(defun make-xmls-builder (&key (include-default-values t) + (include-namespace-uri t)) + "Make a XMLS style builder. When 'include-namespace-uri is true a modified + XMLS tree is generated that includes the element namespace URI rather than + the qualified name prefix and also includes the namespace URI for attributes." + (make-instance 'xmls-builder + :include-default-values include-default-values + :include-namespace-uri include-namespace-uri)) + +(defmethod sax:end-document ((handler xmls-builder)) + (root handler)) + +(defmethod sax:start-element + ((handler xmls-builder) namespace-uri local-name qname attributes) + (let* ((include-default-values (include-default-values handler)) + (include-namespace-uri (include-namespace-uri handler)) + (attributes + (loop + for attr in attributes + for attr-namespace-uri = (sax:attribute-namespace-uri attr) + for attr-local-name = (sax:attribute-local-name attr) + when (and (or (sax:attribute-specified-p attr) + include-default-values) + #+(or) + (or (not include-namespace-uri) + (not attr-namespace-uri) + attr-local-name)) + collect + (list (cond (include-namespace-uri + (cond (attr-namespace-uri + (cons attr-local-name attr-namespace-uri)) + (t + (sax:attribute-qname attr)))) + (t + (sax:attribute-qname attr))) + (sax:attribute-value attr)))) + (namespace (when include-namespace-uri namespace-uri)) + (node (make-node :name local-name + :ns namespace + :attrs attributes)) + (parent (car (element-stack handler)))) + (if parent + (push node (node-children parent)) + (setf (root handler) node)) + (push node (element-stack handler)))) + +(defmethod sax:end-element + ((handler xmls-builder) namespace-uri local-name qname) + (declare (ignore namespace-uri local-name qname)) + (let ((node (pop (element-stack handler)))) + (setf (node-children node) (reverse (node-children node))))) + +(defmethod sax:characters ((handler xmls-builder) data) + (let* ((parent (car (element-stack handler))) + (prev (car (node-children parent)))) + ;; Be careful to accept both rods and strings here, so that xmls can be + ;; used with strings even if cxml is configured to use octet string rods. + (if (typep prev '(or rod string)) + ;; um entities herum wird SAX:CHARACTERS mehrfach aufgerufen fuer + ;; den gleichen Textknoten. Hier muessen wir den bestehenden Knoten + ;; erweitern, sonst ist das Dokument nicht normalisiert. + ;; (XXX Oder sollte man besser den Parser entsprechend aendern?) + (setf (car (node-children parent)) + (concatenate `(vector ,(array-element-type prev)) + prev + data)) + (push data (node-children parent))))) + + +;;;; SAX-Treiber (fuer Serialisierung) + +(defun map-node + (handler node + &key (include-xmlns-attributes sax:*include-xmlns-attributes*) + (include-namespace-uri t)) + (if include-namespace-uri + (map-node/lnames (cxml:make-namespace-normalizer handler) + node + include-xmlns-attributes) + (map-node/qnames handler node include-xmlns-attributes))) + +(defun map-node/lnames (handler node include-xmlns-attributes) + (sax:start-document handler) + (labels ((walk (node) + (unless (node-ns node) + (error "serializing with :INCLUDE-NAMESPACE-URI, but node ~ + was created without namespace URI")) + (let* ((attlist + (compute-attributes/lnames node include-xmlns-attributes)) + (uri (node-ns node)) + (lname (node-name node)) + (qname lname) ;let the normalizer fix it + ) + (sax:start-element handler uri lname qname attlist) + (dolist (child (node-children node)) + (typecase child + (list (walk child)) + ((or string rod) + (sax:characters handler (string-rod child))))) + (sax:end-element handler uri lname qname)))) + (walk node)) + (sax:end-document handler)) + +(defun map-node/qnames (handler node include-xmlns-attributes) + (sax:start-document handler) + (labels ((walk (node) + (when (node-ns node) + (error "serializing without :INCLUDE-NAMESPACE-URI, but node ~ + was created with a namespace URI")) + (let* ((attlist + (compute-attributes/qnames node include-xmlns-attributes)) + (qname (string-rod (node-name node))) + (lname (nth-value 1 (cxml::split-qname qname)))) + (sax:start-element handler nil lname qname attlist) + (dolist (child (node-children node)) + (typecase child + (list (walk child)) + ((or string rod) + (sax:characters handler (string-rod child))))) + (sax:end-element handler nil lname qname)))) + (walk node)) + (sax:end-document handler)) + +(defun compute-attributes/lnames (node xmlnsp) + (remove nil + (mapcar (lambda (a) + (destructuring-bind (name value) a + (unless (listp name) + (setf name (cons name nil))) + (destructuring-bind (lname &rest uri) name + (cond + ((not (equal uri "http://www.w3.org/2000/xmlns/")) + (sax:make-attribute + ;; let the normalizer fix the qname + :qname (if uri + (string-rod (concatenate 'string + "dummy:" + lname)) + (string-rod lname)) + :local-name (string-rod lname) + :namespace-uri uri + :value (string-rod value) + :specified-p t)) + (xmlnsp + (sax:make-attribute + :qname (string-rod + (if lname + (concatenate 'string "xmlns:" lname) + "xmlns")) + :local-name (string-rod lname) + :namespace-uri uri + :value (string-rod value) + :specified-p t)))))) + (node-attrs node)))) + +(defun compute-attributes/qnames (node xmlnsp) + (remove nil + (mapcar (lambda (a) + (destructuring-bind (name value) a + (when (listp name) + (error "serializing without :INCLUDE-NAMESPACE-URI, ~ + but attribute was created with a namespace ~ + URI")) + (if (or xmlnsp + (not (cxml::xmlns-attr-p (string-rod name)))) + (sax:make-attribute :qname (string-rod name) + :value (string-rod value) + :specified-p t) + nil))) + (node-attrs node))))

1 0

[bknr-cvs] r2202 - branches/trunk-reorg/thirdparty
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 15:02:16 -0400 (Thu, 04 Oct 2007) New Revision: 2202 Removed: branches/trunk-reorg/thirdparty/cxml/ Log: update cxml

1 0

[bknr-cvs] r2201 - branches/trunk-reorg/thirdparty/emacs
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 13:27:56 -0400 (Thu, 04 Oct 2007) New Revision: 2201 Removed: branches/trunk-reorg/thirdparty/emacs/slime/ Log: checkpoint

1 0

[bknr-cvs] r2200 - in branches/trunk-reorg/thirdparty: . slime slime/CVS slime/contrib slime/contrib/CVS slime/doc slime/doc/CVS
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 13:23:45 -0400 (Thu, 04 Oct 2007) New Revision: 2200 Added: branches/trunk-reorg/thirdparty/slime/ branches/trunk-reorg/thirdparty/slime/.cvsignore branches/trunk-reorg/thirdparty/slime/CVS/ branches/trunk-reorg/thirdparty/slime/CVS/Entries branches/trunk-reorg/thirdparty/slime/CVS/Entries.Log branches/trunk-reorg/thirdparty/slime/CVS/Repository branches/trunk-reorg/thirdparty/slime/CVS/Root branches/trunk-reorg/thirdparty/slime/CVS/Template branches/trunk-reorg/thirdparty/slime/ChangeLog branches/trunk-reorg/thirdparty/slime/HACKING branches/trunk-reorg/thirdparty/slime/NEWS branches/trunk-reorg/thirdparty/slime/PROBLEMS branches/trunk-reorg/thirdparty/slime/README branches/trunk-reorg/thirdparty/slime/contrib/ branches/trunk-reorg/thirdparty/slime/contrib/CVS/ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries branches/trunk-reorg/thirdparty/slime/contrib/CVS/Repository branches/trunk-reorg/thirdparty/slime/contrib/CVS/Root branches/trunk-reorg/thirdparty/slime/contrib/CVS/Template branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog branches/trunk-reorg/thirdparty/slime/contrib/README branches/trunk-reorg/thirdparty/slime/contrib/bridge.el branches/trunk-reorg/thirdparty/slime/contrib/inferior-slime.el branches/trunk-reorg/thirdparty/slime/contrib/slime-asdf.el branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el branches/trunk-reorg/thirdparty/slime/contrib/slime-banner.el branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el branches/trunk-reorg/thirdparty/slime/contrib/slime-highlight-edits.el branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el branches/trunk-reorg/thirdparty/slime/contrib/slime-presentation-streams.el branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el branches/trunk-reorg/thirdparty/slime/contrib/slime-references.el branches/trunk-reorg/thirdparty/slime/contrib/slime-scratch.el branches/trunk-reorg/thirdparty/slime/contrib/slime-tramp.el branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-asdf.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-c-p-c.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-listener-hooks.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-presentations.lisp branches/trunk-reorg/thirdparty/slime/doc/ branches/trunk-reorg/thirdparty/slime/doc/.cvsignore branches/trunk-reorg/thirdparty/slime/doc/CVS/ branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries branches/trunk-reorg/thirdparty/slime/doc/CVS/Repository branches/trunk-reorg/thirdparty/slime/doc/CVS/Root branches/trunk-reorg/thirdparty/slime/doc/CVS/Template branches/trunk-reorg/thirdparty/slime/doc/Makefile branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.pdf branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.tex branches/trunk-reorg/thirdparty/slime/doc/slime-small.eps branches/trunk-reorg/thirdparty/slime/doc/slime-small.pdf branches/trunk-reorg/thirdparty/slime/doc/slime.texi branches/trunk-reorg/thirdparty/slime/doc/texinfo-tabulate.awk branches/trunk-reorg/thirdparty/slime/hyperspec.el branches/trunk-reorg/thirdparty/slime/metering.lisp branches/trunk-reorg/thirdparty/slime/mkdist.sh branches/trunk-reorg/thirdparty/slime/nregex.lisp branches/trunk-reorg/thirdparty/slime/sbcl-pprint-patch.lisp branches/trunk-reorg/thirdparty/slime/slime-autoloads.el branches/trunk-reorg/thirdparty/slime/slime.el branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp branches/trunk-reorg/thirdparty/slime/swank-backend.lisp branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp branches/trunk-reorg/thirdparty/slime/swank-corman.lisp branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp branches/trunk-reorg/thirdparty/slime/swank-gray.lisp branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp branches/trunk-reorg/thirdparty/slime/swank-loader.lisp branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp branches/trunk-reorg/thirdparty/slime/swank-scl.lisp branches/trunk-reorg/thirdparty/slime/swank-source-file-cache.lisp branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp branches/trunk-reorg/thirdparty/slime/swank.asd branches/trunk-reorg/thirdparty/slime/swank.lisp branches/trunk-reorg/thirdparty/slime/test-all.sh branches/trunk-reorg/thirdparty/slime/test.sh branches/trunk-reorg/thirdparty/slime/xref.lisp Log: update slime Added: branches/trunk-reorg/thirdparty/slime/.cvsignore =================================================================== --- branches/trunk-reorg/thirdparty/slime/.cvsignore 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/.cvsignore 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,6 @@ +*.x86f +*.fasl +*.dfsl +*.lx64fsl +*.elc +_darcs Added: branches/trunk-reorg/thirdparty/slime/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/slime/CVS/Entries 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/CVS/Entries 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,34 @@ +/.cvsignore/1.5/Sun Apr 8 19:23:57 2007// +/ChangeLog/1.1234/Thu Sep 27 12:56:13 2007// +/HACKING/1.8/Wed Sep 19 11:08:27 2007// +/NEWS/1.8/Sun Mar 27 19:41:17 2005// +/PROBLEMS/1.8/Sun Nov 20 23:31:56 2005// +/README/1.14/Tue Oct 3 21:49:13 2006// +/hyperspec.el/1.11/Thu Dec 7 07:36:54 2006// +/metering.lisp/1.4/Fri Apr 1 20:16:35 2005// +/mkdist.sh/1.7/Mon Aug 29 20:02:58 2005// +/nregex.lisp/1.4/Mon Sep 19 08:20:48 2005// +/sbcl-pprint-patch.lisp/1.1/Fri Feb 17 01:30:21 2006// +/slime-autoloads.el/1.3/Thu Sep 20 14:59:08 2007// +/slime.el/1.875/Thu Sep 27 12:56:40 2007// +/swank-abcl.lisp/1.43/Tue Sep 4 15:45:19 2007// +/swank-allegro.lisp/1.98/Wed Sep 26 23:15:41 2007// +/swank-backend.lisp/1.126/Mon Sep 10 15:39:05 2007// +/swank-clisp.lisp/1.64/Thu Aug 23 19:03:37 2007// +/swank-cmucl.lisp/1.174/Wed Sep 5 12:04:43 2007// +/swank-corman.lisp/1.11/Thu Aug 23 19:03:37 2007// +/swank-ecl.lisp/1.8/Thu May 17 11:49:40 2007// +/swank-gray.lisp/1.10/Wed Apr 12 08:43:55 2006// +/swank-lispworks.lisp/1.92/Thu Aug 23 19:03:37 2007// +/swank-loader.lisp/1.73/Fri Sep 14 12:41:28 2007// +/swank-openmcl.lisp/1.119/Thu Aug 23 19:03:37 2007// +/swank-sbcl.lisp/1.185/Tue Sep 11 19:31:03 2007// +/swank-scl.lisp/1.13/Thu Aug 23 19:03:37 2007// +/swank-source-file-cache.lisp/1.8/Tue Dec 5 13:00:42 2006// +/swank-source-path-parser.lisp/1.17/Sun Jun 25 08:33:16 2006// +/swank.asd/1.5/Fri Sep 14 12:41:28 2007// +/swank.lisp/1.511/Wed Sep 19 11:12:07 2007// +/test-all.sh/1.2/Mon Aug 29 20:02:58 2005// +/test.sh/1.9/Mon Aug 27 13:16:49 2007// +/xref.lisp/1.2/Mon May 17 00:25:24 2004// +D Added: branches/trunk-reorg/thirdparty/slime/CVS/Entries.Log =================================================================== --- branches/trunk-reorg/thirdparty/slime/CVS/Entries.Log 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/CVS/Entries.Log 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,2 @@ +A D/contrib//// +A D/doc//// Added: branches/trunk-reorg/thirdparty/slime/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/slime/CVS/Repository 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/CVS/Repository 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1 @@ +slime Added: branches/trunk-reorg/thirdparty/slime/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/slime/CVS/Root 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/CVS/Root 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1 @@ +:pserver:anonymous:anonymous@common-lisp.net:/project/slime/cvsroot Added: branches/trunk-reorg/thirdparty/slime/CVS/Template =================================================================== Added: branches/trunk-reorg/thirdparty/slime/ChangeLog =================================================================== --- branches/trunk-reorg/thirdparty/slime/ChangeLog 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/ChangeLog 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,13172 @@ +2007-09-27 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-filesystem-toplevel-directory): New function. + Windows doesn't have a filesystem that is as hierarchical as the + Unix' one. Reported by Carsten Blaauw and Stefan Kluehspies. + (slime-file-name-merge-source-root): Use it. + (slime-highlight-differences-in-dirname): Use it. + +2007-09-26 Utz-Uwe Haus <haus+slime(a)mail.math.uni-magdeburg.de> + + * swank-allegro.lisp (fspec-definition-locations): Allow the + POSITION datum of :top-level-form fspecs to be missing. This + apparently helpful for Allegro CL 8.1. + +2007-09-21 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-length=, slime-length>): Restore support for + vectors, as `slime-length=' was already used with strings in + `slime-parse.el'. This broke extended arglist display. + +2007-09-20 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-setup): Call the respective init functions of + contribs. + + * slime-autoloads.el (slime-setup-contribs): Ditto. + +2007-09-19 Helmut Eller <heller(a)common-lisp.net> + + Simplify slime-compile-file. + + * slime.el (slime-compile-file): Don't save window config. + (slime-curry, slime-rcurry): New functions. + + * slime.el (slime-complete-symbol*-fancy): Move defcustom to + contrib/slime-c-p-c.el + + * swank-version.el: Delete file. No longer used. + + * bridge.el: Moved to contrib. + + * tree-widget.el: File deleted. Only needed by contribs and is + distributed with Emacs 21. + + * slime.el: Reorder some devfars and menus code so that the + compiler doesn't complain about free variables. + + Fix apropos in Emacs 22. + + * slime.el (slime-print-apropos): Add button props for Emacs 22. + (slime-call-describer): ARG is a marker in Emacs 22. + + (def-slime-selector-method ?c): Wait until slime-list-threads + returns. + + Remove define-slime-dialect. + + * slime.el (define-slime-dialect): Deleted. Use + slime-lisp-implementations instead. + + Introduce a slime-start-and-init function. + + * slime.el (slime-start-and-init, slime-lisp-options): New + functions. + (slime-start-and-load): Use it. + + Simplify slime-length=. + + * slime.el (slime-length=, slime-length>): No need for vectors. + + Remove explicit support for Scheme mode. + + * slime.el (slime-scheme-mode-hook, slime-shared-lisp-mode-hook) + Deleted. + (slime-indentation-update-hooks): New hook. + (slime-handle-indentation-update): Use it. + + Fix close-connection. + + * swank.lisp (close-connection): Use *log-output* instead of + *debug-io* (which could be redirected to the to-be-closed + connection). + +2007-09-15 Helmut Eller <heller(a)common-lisp.net> + + Let slime-setup load contribs. + + * slime.el (slime-setup): Take a list of contribs to load as + argument. + + * slime-autoloads.el (slime-setup): Ditto, but delay the actual + loading until slime is loaded. + (slime-setup-contribs): New function. + +2007-09-15 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-maybe-warn-for-different-source-root): Catch + returned NIL from `slime-file-name-merge-source-root' if the two + filenames don't share a common source root. + Reported by Frank Goenninger. + +2007-09-15 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-split-string): New semi-portability function. + The behaviour of `split-string' changed between Emacs21 and + Emacs22. Thanks to Christophe Rhodes for reporting this. + (slime-file-name-merge-source-root): Use `slime-split-string'. + (slime-highlight-differences-in-dirname): Likewise. + +2007-09-14 Helmut Eller <heller(a)common-lisp.net> + + Some cleanups for the REPL. + + * slime.el (slime-repl-write-string): Split it up into smaller + functions. + (slime-repl-emit, slime-repl-emit-result) + (slime-emit-string): New functions. + + (slime-repl-save-history): Use prin1 instead of pp. + + (repl-type-ahead): New test case. + +2007-09-12 Christophe Rhodes <csr21(a)cantab.net> + + Make ASDF:LOAD-OP (and SBCL REQUIRE) happy with swank.asd + + * swank.asd: Define and use a CL-SCRIPT-FILE class for loading as + source, even with ASDF:LOAD-OP. + +2007-09-11 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-loader.lisp: Aways compile-file `contrib/swank-asdf.lisp' + on SBCL. This fixes "Undefined function" style-warnings when using + `slime-asdf' in combination with SBCL. Reported by Cyrus Harmon. + + * swank-sbcl.lisp: Explicitly require ASDF. (While this is not + strictly necessary, as it's implicitly loaded on requiring the + other modules, I think it's better to be explicit about it.) + +2007-09-10 Helmut Eller <heller(a)common-lisp.net> + + Fix some bugs introduced while moving doc refs to contrib. + + * swank-sbcl.lisp (condition-references): It's still needed. + + * slime.el (sldb-dispatch-extras): Add missing quote. + (slime-sbcl-manual-root): Move definition to + contrib/slime-references.el. + (slime-cl-symbol-name, slime-cl-symbol-package): Move to + contrib/slime-parse.el. + +2007-09-10 Helmut Eller <heller(a)common-lisp.net> + + Move SBCL doc references to contrib. + + * slime.el (sldb-insert-condition): Merge REFERENCES and EXTRAS. + (sldb-extras-hooks, sldb-dispatch-extras): New hook. + + * swank-backend.lisp (condition-references): Removed. Merged with + condition-extras. + + * swank-sbcl.lisp (condition-references): Removed. + (condition-extras): Include references. + (externalize-reference): New function. Don't return plain + symbols. + + * swank-allegro.lisp (condition-references): Removed. + +2007-09-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-cl-symbol-name, slime-cl-symbol-package): + Ressurected, as they're still used in this file. + Reported by Edward Cant. + +2007-09-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + When working on multiple source trees simultaneously, the way + `slime-edit-definition' (M-.) works can sometimes be confusing: + + `M-.' visits locations that are present in the current Lisp image, + which works perfectly well as long as the image reflects the + source tree that one is currently looking at. + + In the other case, however, one can easily end up visiting a file + in a different source root directory (the one corresponding to the + Lisp image), and is thus easily tricked to modify the wrong source + files---which can lead to quite some stressfull cursing. + + If the variable `slime-warn-when-possibly-tricked-by-M-.' is + T (the default), a warning message is issued to raise the user's + attention whenever `M-.' is about opening a file in a different + source root that also exists in the source root directory of the + user's _current buffer_. + + There's no guarantee that all possible cases are covered, but if + you encounter such a warning, it's a strong indication that you + should check twice before modifying. + + * slime.el (slime-file-name-merge-source-root): New function. + (slime-highlight-differences-in-dirname): New function. + (slime-maybe-warn-for-different-source-root): New function. + (slime-warn-when-possibly-tricked-by-M-.): New variable (T by default.) + (slime-goto-location-buffer): Where appropriate, call + `slime-maybe-warn-for-different-source-root' + +2007-09-08 Stelian Ionescu <sionescu(a)common-lisp.net> + + * slime.el (save-restriction-if-possible): Place macro definition + above use of the macro, to regain ability to byte-compile-file. + +2007-09-08 Tobias C. Rittweiler <tcr(a)freebits.de> + + Fix message displaying on XEmacs. Reported by Steven E. Harris, + and Ken Causey. + + * slime.el (slime-display-message): Resurrect secondary + `buffer-name' argument which got lost in 2007-08-24. + (slime-format-display-message): Resurrect passing "*SLIME Note*" + as default buffer-name to `slime-display-message'. + +2007-09-08 Matt Pillsbury <mtbp(a)rci.rutgers.edu> + + * swank-backend.lisp (definterface): Updated docstring. + +2007-09-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-repl-write-string): Use case, not ecase, for + dispatching targets.Should fix XEmacs compatibility. + Reported by Steven E. Harris. + +2007-09-05 Didier Verna <didier(a)xemacs.org> + + * slime.el (slime-filename-translations): Fix custom type. + +2007-09-05 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-toggle-trace-fdefinition): Fix typo. The + argument for interactive should be "P" not "p". + +2007-09-04 Mark Evenson <mark.evenson(a)gmx.at> + + * swank-abcl.lisp: Call accessors of compiler-condition at load + time to work around some ABCL problems. + +2007-09-04 Helmut Eller <heller(a)common-lisp.net> + + Move asdf support to contrib. + + * swank-backend.lisp (operate-on-system): Moved to + swank-asdf.lisp. It wasn't specialized in any backend. + + * swank.lisp (operate-on-system-for-emacs) + (list-all-systems-known-to-asdf, list-asdf-systems): Moved to + swank-asdf.lisp. + + * slime.el: Move asdf commands to contrib slime-adsf.el. + + * swank-loader.lisp: Load swank-asdf if ASDF is in + *FEATURES*. Also add the contrib source directory to + swank::*load-path*. + +2007-09-04 Helmut Eller <heller(a)common-lisp.net> + + * slime.el: Move tramp support to contrib. + +2007-09-04 Helmut Eller <heller(a)common-lisp.net> + + Move startup animation to contrib. + + * slime.el (slime-repl-banner-function): New hook. + (slime-repl-update-banner): Use it and reset markers after calling + it. + (slime-set-default-directory): Don't call slime-repl-update-banner + here. + (slime-repl-insert-prompt): Set slime-repl-input-end-mark to + point-max. + +2007-09-04 Helmut Eller <heller(a)common-lisp.net> + + * slime.el: Move inferior-slime-mode to contrib. + +2007-09-04 Helmut Eller <heller(a)common-lisp.net> + + * slime.el: Fix the test suite (except for SBCL). + +2007-09-04 Helmut Eller <heller(a)common-lisp.net> + + Simplify slime-process-available-input. + + * slime.el (slime-process-available-input): We are called in a + process filter, i.e. at arbitrary times and in an aribtrary + buffer. So it doesn't make sense to save-and-restore the current + buffer here + (slime-eval-async): Instead, save and restore the buffer here. + (slime-net-read-or-lose): New. + +2007-09-04 Helmut Eller <heller(a)common-lisp.net> + + Remove request-abort condition. + + * swank-backend.lisp (request-abort): Removed + (abort-request): Removed. Replace all (3) uses with ERROR. + * swank.lisp (eval-for-emacs): No special case for request-abort. + * slime.el (slime-eval-async): Remove optional arg of :abort. + +2007-09-04 Helmut Eller <heller(a)common-lisp.net> + + Rename slime-insert-possibly-as-rectangle to slime-insert-indented. + + * slime.el (slime-insert-indented): Renamed. Update callers. + +2007-08-31 Helmut Eller <heller(a)common-lisp.net> + + Move compound prefix completion and autodoc to contrib. + + * swank.lisp (simple-completions): Rewritten for simplicity. + (operator-arglist): Rewritten for simplicity. + + * slime.el (slime-complete-symbol-function): Make simple + completion the default. + (slime-echo-arglist-function, slime-echo-arglist): New hook. + + Remove corresponding key bindigs. + + * slime.el (slime-obsolete-commands): New table. Use it to bind + a command with an upgrade notice. + +2007-08-31 Andreas Fuchs <asf(a)boinkor.net> + + * slime.el (slime-reindent-defun): Fixed when used in lisp file + buffers. (Similiar patch also provided by G�bor Melis; problem + also reported by Jeff Cunningham.) + +2007-08-31 Jon Allen Boone <ipmonger(a)delamancha.org> + + * swank-cmucl.lisp: CMUCL now has an x86-Darwin port as well as + the PPC-Darwin version. Changed to conditionalize on the + presence of darwin instead of ppc so that slime works with both + Darwin versions of CMUCL. + +2007-08-31 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-sexp-at-point): Explicitely set current syntax + table to operate in `lisp-mode-syntax-table' because + `thing-at-point' is used which depends on the syntax table. (E.g. + keywords like `:foo' aren't recognized as sexp otherwise.) + + * slime.el (slime-parse-extended-operator/declare): Wrap regexp + stuff in `save-match-data' + (slime-internal-scratch-buffer): Removed again. Was only + introduced as a performance hack; but it turned out that the bad + performance was because of unneccessary recursive calls of + `slime-make-form-spec-from-string'. (Which was fixed on 2007-08-27 + already.) + (slime-make-form-spec-from-string): Use `with-temp-buffer' instead + of `slime-internal-scratch-buffer'. Removed activation of + `lisp-mode' in the temporary buffer, because this made + `lisp-mode-hooks' run. This activated autodoc in the temp buffer, + although the temp buffer is used to compute an autodoc + itself (which resulted in some very mutual recursion which caused + the current arglist to be displayed again and again---as could + have been witnessed in `*Messages*'.) `Lisp-mode' was activated to + get the right syntax-table for `slime-sexp-at-point', but this one + sets the correct syntax-table itself now. + +2007-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Fix user input type-ahead again (this change from 2007-08-25 got + lost). Testcase: Type (dotimes (i 5) (format t "Number ~A~%" + i) (sleep 1)) and then type ahead while the command is executing + and output arrives. + + * slime.el (slime-repl-insert-prompt): Don't go to point-max but + to slime-repl-input-start-mark if there is one. + (slime-repl-write-string): Insert a :repl-result before the + prompt, not at point-max. Update markers properly. + +2007-08-28 Helmut Eller <heller(a)common-lisp.net> + + * swank-cmucl.lisp (safe-definition-finding): Remove whitespace + around error messages. + (trim-whitespace): New function. + +2007-08-28 Helmut Eller <heller(a)common-lisp.net> + + Fix some output related bugs. + + * swank.lisp (send-repl-results-to-emacs): Emit a fresh line. + + * slime.el (slime-insert-transcript-delimiter): Use + insert-before-markers since slime-output-end is no longer left + inserting. Reported by Austin Haas <austin(a)pettomato.com>. + +2007-08-28 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-display-or-scroll-completions, + slime-scroll-completions): New functions. Factored out of + slime-expand-abbreviations-and-complete. + +2007-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-repl-write-string): Handle arbitrary targets + using slime-output-target-marker. + (slime-last-output-target-id, slime-output-target-to-marker) + (slime-output-target-marker) + (slime-redirect-trace-output): Move back here from slime-presentations.el. + +2007-08-28 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp (classify-symbol, symbol-classification->string): + Resurrected in swank.lisp. (I was bitten by cvs-pcl which + committed (2007-08-27) my locally changed `contribs/swank-fuzzy.lisp' + where I already removed these functions from.) + +2007-08-28 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-make-form-spec-from-string): Elisp Hacking 101: + Don't use `beginning-of-buffer' and `end-of-buffer' in Elisp code. + + * swank.lisp (read-form-spec): Unintern just newly interned + symbols when an reader error occurs. + +2007-08-28 Helmut Eller <heller(a)common-lisp.net> + + Move presentations to contrib. Part II. + + * swank.lisp (*listener-eval-function*): New variables. + (listener-eval): Use it + (repl-eval): Used to be listener-eval. + (*send-repl-results-function*): New variable. + (eval-region): Simplify. + (track-package, cat): New functions. + (slime-repl-clear-buffer-hook): New hook. + (slime-repl-clear-buffer): Use it. + +2007-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Remove the ID argument from :write-string protocol messages. + Everything, except for rigid-indentation tricks, can be achieved + by using :write-string in conjunction with :presentation-start and + :presentation-end. + + * swank.lisp (present-in-emacs): Unused, removed. + + * swank.lisp (make-output-function-for-target): Remove id argument + from :write-string. + (send-repl-results-to-emacs): Don't call + save-presented-object. Remove id argument from :write-string. + + * slime.el (slime-dispatch-event): Change it here. + (slime-write-string, slime-repl-write-string): And here. + +2007-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank-loader.lisp (*contribs*): Add swank-presentations. + +2007-08-27 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-make-extended-operator-parser/look-ahead): Move + to end of symbol at point. + (slime-make-form-spec-from-string): Fixes unexpected behaviour of + `save-excursion'. + +2007-08-27 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-sexp-at-point): Fixes a few edge cases were + Emacs' `(thing-at-point 'sexp)' behaves suboptimally. For example, + `foo(bar baz)' where point is at the ?\(. + (slime-internal-scratch-buffer): New. This variable holds an + internal scratch buffer that can be reused instead of having to + create a new temporary buffer again and again. + (slime-make-extended-operator-parser/look-ahead): Uses + `slime-make-form-spec-from-string' to parse nested expressions + properly. + (slime-nesting-until-point): Added docstring. + (slime-make-form-spec-from-string): Added new optional parameter + for stripping the operator off the passed string representation of + a form. Necessary to work in the context of + `slime-make-extended-operator-parser/look-ahead'. Added safety check + against a possible endless recursion. + + * swank.lisp (parse-form-spec): Looses restriction for nesting. + +2007-08-27 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-eval-feature-conditional): Fix typo. + (slime-keywordify): Simplify. + +2007-08-27 Helmut Eller <heller(a)common-lisp.net> + + Move presentations to contrib. Part I. + + * slime.el (slime-event-hooks, slime-dispatch-event): New hook. + (slime-write-string-function, slime-write-string): New hook. + (slime-repl-return-hooks, slime-repl-return): New hook. + (slime-repl-current-input-hooks, slime-repl-current-input): New hook. + (slime-open-stream-hooks, slime-open-stream-to-lisp): New hook. + (sldb-insert-locals, slime-inspector-insert-ispec) + (slime-last-expression): Don't use presentations. + +2007-08-26 Tobias C. Rittweiler <tcr(a)freebits.de> + + Reduces needless interning of symbols that was introduced by my + recent work on autodoc to a minimum. Also fixes this issue for + `slime-complete-form' which always interned symbols even before my + changes. + + * slime.el (slime-sexp-at-point): If N is given, but there aren't + N sexps available at point, make it return a list of just as many + as there are. + (slime-make-form-spec-from-string): New. Creates a ``raw form + spec'' from a string that's suited for determining newly interned + symbols later in Swank. + (slime-parse-extended-operator/declare): Uses it. + + * swank.lisp (parse-symbol): Returns internal knowledge, to + provide a means for callers to perform a sanity check. + (call-with-ignored-reader-errors): New. Abstracted out from + `read-incomplete-form-from-string.' + + * swank.lisp (read-form-spec): New. Only READs elements of a form + spec if necessary. And if it does have to READ, it keeps track + of newly interned symbols which are returned as secondary + return value. + (parse-form-spec): Use it. Propagate newly interned symbols. + (parse-first-valid-form-spec): Likewise. + (arglist-for-echo-area, complete-form, completions-for-keyword): + Adapted to unintern the newly interned symbols. + + +2007-08-26 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (current-slime-narrowing-configuration): + Renamed to `slime-current-narrowing-configuration'. + (set-slime-narrowing-configuration): + Renamed to `slime-set-narrowing-configuration'. + (current-slime-emacs-snapshot): + Renamed to `slime-current-emacs-snapshot'. + (current-slime-emacs-snapshot-fingerprint): + Renamed to `slime-current-emacs-snapshot-fingerprint'. + (set-slime-emacs-snapshot): + Renamed to `slime-set-emacs-snapshot'. + +2007-08-26 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (save-restriction-if-possible): Fixed another typo, + duh! Thanks again to Matthias Koeppe. + +2007-08-26 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-cl-symbol-name): Handle vertical bars (|) + (%slime-nesting-until-point): Renamed to `slime-nesting-until-point'. + +2007-08-25 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Fix a bug where REPL results would sometimes be indented by a + random amount. + + * slime.el (slime-insert-presentation): Make the + rectangle-ification of multi-line presentations, introduced + 2006-12-19, optional. + (slime-write-string): Use it here only for regular output, but not + for REPL results. + (sldb-insert-locals): Use it here. + (slime-inspector-insert-ispec): Use it here. + +2007-08-25 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Fix handling of user-input type-ahead in the REPL. + Reported by Madhu <enometh(a)meer.net> on 2007-04-24. + + * slime.el (slime-write-string): Make sure text properties are + rear-nonsticky, so typed-ahead user input does not pick up the + text properties. Fix up some markers. + (slime-reset-repl-markers): Make the marker slime-output-end of + insertion type nil (no automatic advances on insertions). + (slime-with-output-end-mark): Update the location of + slime-output-end here manually. + (slime-repl-update-banner): Use insert-before-markers. + +2007-08-25 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + New command slime-redirect-trace-output creates a separate Emacs + buffer, where all subsequent trace output is sent. + + * slime.el (slime-last-output-target-id): New variable. + (slime-output-target-to-marker): New variable. + (slime-output-target-marker): New function. + (slime-write-string): Handle general "target" arguments using + slime-output-target-marker. + (slime-redirect-trace-output): New command. + (slime-easy-menu): Add a menu item for it. + + * slime.el (slime-mark-presentation-start) + (slime-mark-presentation-end): Make "target" argument optional. + Use slime-output-target-to-marker. + + * swank.lisp (make-output-stream-for-target): New function, + factored out from open-streams. + (open-streams): Use it here. + + * swank.lisp (connection): New slot "trace-output". + (call-with-redirected-io): Use it here. + (redirect-trace-output): New slimefun; set the slot to a new + target stream. + +2007-08-25 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (save-restriction-if-possible): Fixed typo in + macroexpansion. Thanks to Matthias Koeppe for reporting. + +2007-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-insert-arglist): Removed, superseded by + slime-complete-form since 2005-02-20. + + * swank.lisp (arglist-for-insertion): Now unused, removed. + +2007-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Some fixes to the presentation-streams contrib. + + * slime.el (slime-dispatch-event): Handle new optionals args of + messages :presentation-start and :presentation-end. + + * slime.el (slime-mark-presentation-start) + (slime-mark-presentation-end): New arg "target"; record + presentation boundaries separately for REPL results and regular + process output. This fixes the presentation markup of REPL + results when the presentation-streams contrib is loaded. + +2007-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Make the fancy presentation-streams feature a contrib. + Previously, it was only available if "present.lisp" was loaded + manually. Now it can be loaded automatically using: + + (add-hook 'slime-load-hook + (lambda () (require 'slime-presentation-streams))) + + Note that the normal presentations that are created by REPL + results, the inspector, and the debugger are NOT dependent on this + code. + + * present.lisp: Moved to contrib/swank-presentation-streams.lisp. + * swank-loader.lisp (*contribs*): Add swank-presentation-streams. + +2007-08-24 Helmut Eller <heller(a)common-lisp.net> + + Move typeout frame to contrib. + + * slime.el (slime-message-function, slime-background-message-function) + (slime-autodoc-message-function): New variables. + (slime-message, slime-background-message) + (slime-autodoc-message): Call the function in the respective + variable, so that the typeout window can be plugged in. + +2007-08-24 Helmut Eller <heller(a)common-lisp.net> + + Move xref and class browser to contrib. + + * slime.el (slime-browse-classes, slime-browse-xrefs): Gone. The + Common Lisp part is still there. + +2007-08-24 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-forward-blanks): Wrapped w/ `ignore-errors.' + (slime-sexp-at-point): Return results as a list of strings, rather + than just one big string if called with arg > 1. + (slime-parse-extended-operator-name): Wrapping some movement code + in `ignore-errors'. Adapted to new return value of + `slime-enclosing-form-specs'. Minor cosmetic changes. + (slime-make-extended-operator-parser/look-ahead): Adapted to + changes of the ``raw form spec'' format; returns a form of + strings, instead of a string of a form. + (slime-parse-extended-operator/declare): Simplified. Adapted to + changes of the ``raw form spec'' format; passes decl-identifiers, + or typespec-operators respectively, along the decl/type-spec. + (%slime-in-mid-of-typespec-p): Removed. Replaced by an regexp + based approach. + (%slime-nesting-until-point): New helper for + `slime-parse-extended-operator/declare'. + + * swank.lisp (parse-form-spec): Adapted to new ``raw form spec'' + format. Updated format description in docstring accordingly. The + new format allows less interning of wrong symbols names comming + from Slime. Thanks to Matthias Koeppe for spotting this. + +2007-08-24 Helmut Eller <heller(a)common-lisp.net> + + Move slime-highlight-edits-mode to contrib. + +2007-08-24 Helmut Eller <heller(a)common-lisp.net> + + Move slime-scratch to contrib. + + * slime.el (slime-scratch): Gone. + +2007-08-24 Helmut Eller <heller(a)common-lisp.net> + + Various cleanups related to slime-insert-propertized. + + * slime.el (slime-with-rigid-indentation): Fix evaluation order. + (slime-indent-rigidly): New. + (slime-insert-possibly-as-rectange): Don't set mark. + (slime-insert-propertized): Use plain insert instead of + slime-insert-possibly-as-rectange. + +2007-08-24 Helmut Eller <heller(a)common-lisp.net> + + * swank-sbcl.lisp (sbcl-inspector): Fix typo. + +2007-08-23 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Repair inspection of presentations. + + * swank.lisp (inspect-presentation): New slimefun. + * slime.el (slime-inspect-presentation-at-mouse): Use it here. + +2007-08-23 Helmut Eller <heller(a)common-lisp.net> + + Move Marco Baringer's inspector to contrib. + + * swank.lisp (*default-inspector*): New variable. Set this + variable dispatch to different inspectors. + (inspect-object): Use it. + + * swank-loader.lisp (*contribs*): Add 'swank-fancy-inspector. + + * swank-backend.lisp (backend-inspector): New class. Introduce a + named class to give as another way to dispatch to backend methods. + + * swank-cmucl.lisp: Use backend-inspector class. + * swank-sbcl.lisp: Use backend-inspector class. + * swank-clisp.lisp: Use backend-inspector class. + * swank-lispworks.lisp: Use backend-inspector class. + * swank-allegro.lisp: Use backend-inspector class. + * swank-openmcl.lisp: Use backend-inspector class. + * swank-abcl.lisp: Use backend-inspector class. + * swank-corman.lisp: Use backend-inspector class. + * swank-scl.lisp: Use backend-inspector class. + +2007-08-23 Tobias C. Rittweiler <tcr(a)freebits.de> + + Added arglist display for declaration specifiers and type + specifiers. + + Examples: + + `(declare (type' will display + + (declare (type type-specifier &rest vars)) + + `(declare (type (float' will display + + [Typespec] (float &optional lower-limit upper-limit) + + `(declare (optimize' will display + + (declare (optimize &any (safety 1) (space 1) (speed 1) ...)) + + &ANY is a new lambda keyword that is introduced for arglist + description purpose, and is very similiar to &KEY, but isn't based + upon plists; they're more based upon *FEATURES* lists. (See the + comment near the ARGLIST defstruct in `swank.lisp'.) + + * slime.el: + (slime-to-feature-keyword): Renamed to `slime-keywordify'. + (slime-eval-feature-conditional): Adapted to use `slime-keywordify'. + (slime-ensure-list): New utility. + (slime-sexp-at-point): Now takes an argument that specify how many + sexps at point should be returned. + (slime-enclosing-operator-names): Renamed to + `slime-enclosing-form-specs'. + (slime-enclosing-form-specs): Returns a list of ``raw form specs'' + instead of what was called ``extended operator names'' before, see + `swank::parse-form-spec' for more information. This is a + simplified superset. Additionally as tertiary return value return + a list of points to let the caller see where each form spec is + located. Adapted callers accordingly. Extended docstring. + (slime-parse-extended-operator-name): Adapted to changes in + `slime-enclosing-form-specs'. Now gets more context, and is such + more powerful. This was needed to allow parsing DECLARE forms. + (slime-make-extended-operator-parser/look-ahead): Because the + protocol for arglist display was simplified, it was possible to + replace the plethora of parsing function just by this one. + (slime-extended-operator-name-parser-alist): Use it. Also add + parser for DECLARE forms. + (slime-parse-extended-operator/declare): Responsible for parsing + DECLARE forms. + (%slime-in-mid-of-typespec-p): Helper function for + `slime-parse-extended-operator/declare'. + (slime-incomplete-form-at-point): New. Return the ``raw form + spec'' near point. + (slime-complete-form): Use `slime-incomplete-form-at-point'. + + * swank.lisp: New Helper functions. + (length=, ensure-list, recursively-empty-p): New. + (maybecall, exactly-one-p): New. + + * swank.lisp (arglist-for-echo-area): Adapted to take ``raw form + specs'' from Slime. + (parse-form-spec): New. Takes a ``raw form spec'' and returns a + ``form spec'' for further processing in Swank. Docstring documents + these two terms. + (split-form-spec): New. Return relevant information from a form spec. + (parse-first-valid-form-spec): Replaces `find-valid-operator-name'. + (find-valid-operator-name): Removed. + (operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'. + + (defstruct arglist): Add `any-p' and `any-args' slots to contain + arguments belonging to the &ANY lambda keyword. + (print-arglist): Adapted to also print &ANY args. + (print-decoded-arglist-as-template): Likewise. + (decode-arglist): Adapted to also decode &ANY args. + (remove-actual-args): Adapted to also remove &ANY args. + (remove-&key-args): Split out from `remove-actual-args'. + (remove-&any-args): New. Removes already provided &ANY args. + (arglist-from-form-spec): New. Added detailed docstring. + (arglist-dispatch): Dispatching generic function for + `arglist-from-form-spec' that does all the work. Renamed from + prior `form-completion'. + (arglist-dispatch) Added methods for dealing with declaration and + type-specifiers. + (complete-form): Adapted to take ``raw form specs'' from Slime. + (completions-for-keyword): Likewise. + (format-arglist-for-echo-area): Removed. Not needed anymore. + + * swank-backend.lisp (declaration-arglist): New generic + function. Returns the arglist for a given declaration + identifier. (Backends are supposed to specialize it if they can + provide additional information.) + (type-specifier-arglist): New generic function. Returns the + arglist for a given type-specifier operator. (Backends are + supposed to specialize it if they can provide additional + information.) + (*type-specifier-arglists*): New variable. Contains the arglists + for the type specifiers in Common Lisp. + + * swank-sbcl.lisp: Now depends upon sb-cltl2. + (declaration-arglist 'optimize): Specialize the `optimize' + declaration identifier to pass it to + sb-cltl2:declaration-information. + + +2007-08-23 Helmut Eller <heller(a)common-lisp.net> + + Some inspector cleanups. + + * slime.el (slime-inspect): Remove dwim stuff and drop keyword + args. + (slime-read-object): Killed. + (slime-open-inspector): Drop keyword args. Update callers + accodordingly, expect presentation related code. Presentations no + longer work in the inspector. + + * swank.lisp (*inspector-dwim-lookup-hooks*) + (default-dwim-inspector-lookup-hook): Deleted. + (init-inspector): Sanitize arglist. + (inspect-object): Don't return an :id for *inspectee-parts*. + + * swank-backend (type-for-emacs): Removed. No backend implemented + it. + +2007-08-23 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-fuzzy-upgrade-notice): New function. Bound to + the key where slime-fuzzy-complete-symbol used to be. + +2007-08-22 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-close-all-parens-in-sexp): Fix interplay with + `slime-close-parens-limit'. This should also affect + `slime-complete-form' (C-c C-s) in a positive way. + +2007-08-19 Helmut Eller <heller(a)common-lisp.net> + + * contrib: New directory. Move fuzzy completion code to that + directory. + + * swank.lisp (swank-require): New function to load contrib code. + (*find-module*, module-filename, *load-path*, merged-directory) + (find-module, module-canditates): New. Pathname acrobatics for + swank-require. + + * swank-loader.lisp: Compile (but don't load) contribs. + (*contribs*, contrib-source-files): New. + +2007-08-16 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-process-available-input): Correct yesterday's + change: the buffer a request was originally performed in doesn't + necessarily exist at this time anymore, so we check for buffer + liveness now. + + The problem arised when quitting in SLDB which would cause Swank + to send a `:debug-return' message before the acknowledgement + message for `sldb-quit' is sent. So the acknowledgement is + received in a context where the sldb-buffer is closed already. + +2007-08-15 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-process-available-input): Make sure that the + event received from SWANK is processed in the context of the + original buffer the request of the response was performed in. + Previously, the clauses of `slime-rex' were processed in the + internal *cl-connection* buffer. And as a result the continuations + passed to `slime-eval' and `slime-eval-async' ditto. + +2007-08-15 Tobias C. Rittweiler <tcr(a)freebits.de> + + Make `M-.' work on definitions outside the current restriction. + `M-,' will also properly restore the narrowing as of before the + jump. Similiarly for quiting from the compilation notes buffer and + the Xref buffers. + + * slime.el (slime-narrowing-configuration, slime-emacs-snapshot), + (current-slime-narrowing-configuration), + (set-slime-narrowing-configuration), + (current-slime-emacs-snapshot), + (set-slime-emacs-snapshot), + (current-slime-emacs-snapshot-fingerprint): New. Emacs' window + configurations do not restore narrowing, so introduce a + snapshot facility that contains the necessary information. + + * slime.el: Various renaming and adaptions in the Slime temp + buffer, xref, goto-definition and compilation notes section to use + the newly introduced snapshots instead of mere window + configurations. + + * slime.el: (slime-highlight-notes, slime-remove-old-overlays): + Still operate on whole buffer, but restore previous restriction if + there was any. + (slime-goto-location-position): Now widens the buffer to properly + jump to definitions outside of the current restriction. + + * slime.el (slime-push-definition-stack), + (slime-pop-find-definition-stack): Now also stores information + about narrowing on the definition stack, in order to properly + restore narrowing on `M-,'. + + * slime.el (def-slime-test narrowing): Test case for properly + dealing with narrowing. + + * slime.el (slime-buffer-narrowed-p): New function, tests whether + the current buffer is narrowed or not. + (save-restriction-if-possibly): Like `save-restriction', but not + as strict---see doc string. + + * slime.el (slime-length=): New function; semantically the same + as (= (length seq) n), but more efficiently implemented for lists. + Changed the above pattern into a call to SLIME-LENGTH= where + appropriate. + +2007-08-05 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (backtrace): Handle printer errors while printing a + frame. This makes debugging print-object methods with SLIME + easier. Reported by Utz-Uwe Haus. + +2007-08-02 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-kill-all-buffers): Now also kills all buffers + beginning with a `*SLIME' prefix (like, for instance, `*SLIME + Apropos*', or `*SLIME macroexpansion*'.) + +2007-06-28 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (def-slime-selector-method): Revert Marco's change from + 2007-05-23. BODY can return a buffer name, like "*slime-events*". + Handle that and never ignore invalid return values. Force BODY to + abort if there's no suitable buffer. Why would you want to switch + buffers if the desired buffer doesn't exist? + +2007-06-27 Tobias C. Rittweiler <tcr(a)freebits.de> + + Fixing `C-c M-q' at the REPL. Thanks to Andr� Thieme for pointing + out that it has been broken since several months. + + * slime.el (slime-reindent-defun): Use functions + `slime-beginning-of-defun' and `slime-end-of-defun' that were + introduced in the last changeset. + +2007-06-16 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el: Pressing `C-M-a' (beginning-of-defun) in midst of the + last REPL prompt directs the cursor to the beginning of the + prompt. Pressing it again, would do nothing; now it moves the + cursor to the start of the previous prompt (as it's consistent + with the behaviour when the cursor was placed midst one of the old + prompts.) + + Likewise for `C-M-e' (end-of-defun) + + Additionally fixing `C-c C-s' (slime-complete-form) at the REPL. + + (slime-keys): New bindings for `C-M-a' and `C-M-e' to + SLIME-BEGINNING-OF-DEFUN and SLIME-END-OF-DEFUN respectively. + (slime-keys): Making `C-c C-q' (slime-close-parens-at-point) + obsolete, as it didn't work correctly on the REPL. + (slime-repl-mode-map): Removed bindings for `C-M-a' and `C-M-e', + as they're now inherited from SLIME-KEYS. + (slime-repl-beginning-of-defun, slime-repl-end-of-defun): Jump to + the previous (next) prompt if called twice in a row. + + (slime-close-parens-at-point): Commented out. + (slime-close-all-sexp): Renamed to SLIME-CLOSE-ALL-PARENS-IN-SEXP. + (slime-close-all-parens-in-sexp): Modified to take + SLIME-CLOSE-PARENS-LIMIT into account. + (slime-complete-form): Use SLIME-CLOSE-ALL-PARENS-IN-SEXP. + + +2007-05-24 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp: Fixed regression in completion: "swank[TAB]" would + previously be completed to "swank-backend:"; "get-internal[TAB]" + would be completed to "get-internal-r-time" (instead of simply + "get-internal-r"); and "custom:*comp[TAB]" would be completed to + "custom:*compiled-" on CLISP, even though there's a + "custom:*complile-". + + Thanks to Ken Causey for helping me find the first two. + + (completions): Revert changes from 2007-05-11. + (longest-compound-prefix): Fixed to properly generate a compound + _prefix_. + +2007-05-23 Marco Baringer <mb(a)bese.it> + + * slime.el (def-slime-selector-method): Allow the selector body to + not return a buffer. This means that, instead of being to forced + to signal an error when a choosen buffer can't be found (like + choosing d when there are no debugger buffers) can simply display + a message. + + Fix handling of auto-flushing on sbcl: + + * swank-sbcl.lisp (*auto-flush-interval*): New variable + controlling how often streams are flushed. + (*auto-flush-lock*): New lock guarding access to the shared + variable *auto-flush-streams*. + (make-stream-interactive): Wrapped access to *auto-flush-streams* + in a call-with-recursive-lock-held. + (flush-streams): Wrapped in call-with-recursive-lock-held. + +2007-05-17 Martin Simmons <martin(a)lispworks.com> + + * swank-lispworks.lisp (lispworks-inspect): Fix hanging caused by + mapcan, i.e. nconc, on a constant list returned by + label-value-line. + +2007-05-17 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-complete-form): Only insert a closing + parenthesis if the form is not already closed. Reported by and + adapted from Mac Chan. + +2007-05-17 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp: Fixed bug in completion as previously "swank:[tab]" + would correctly list all the symbols in SWANK, but would + simultaneously append a spooky dash to the original + string ("swank:-"). + + (completions): Strip off the package identifier part, and only + compute the longest compound prefix for the actual symbol + identifiers. + (untokenize-symbol): New function. Inverse of TOKENIZE-SYMBOL. + (format-completion-result): Use UNTOKENIZE-SYMBOL. + +2007-05-17 Dustin Long <dlong(a)stevens.edu> + + * swank-ecl.lisp (compile-from-stream): Fixed typo that prevented + `slime-compile-defun' from actually compiling a function. + +2007-05-17 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-loader.lisp (*sysdep-files*): Load the auxiliary files + swank-source-*.lisp before swank-sbcl.lisp to avoid + undefined-function style warnings. + +2007-05-16 Takehiko Abe <keke(a)gol.com> + + * swank.lisp (inspect-for-emacs file-stream, stream-error): Fixed + typo in keyword arg; it's `:refreshp', not `:refresh'. + +2007-05-14 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el: Fixed proper handling of the abortion of a + request. (For instance, when calling (SWANK::ABORT-REQUEST "FOO") + from the REPL.) + + (sldb-quit): Updated the DESTRUCTURE-CASE clause for (:abort) to + take an argument. + (sldb-continue): Likewise. + (sldb-invoke-restart): Likewise. + (sldb-break-with-default-debugger): Likewise. + (sldb-return-from-frame): Likewise. + (sldb-restart-frame): Likewise. + (slime-repl-eval-string) Likewise. + (slime-repl-show-abort): Now also inserts the reason for the abort + into the REPL buffer. + + * swank.lisp (eval-for-emacs): Remove code that would suggest that + it's possible to use the rex `(:abort ...)' with more than one + argument. + +2007-05-14 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp: Liberated from unnecessary style-warnings! + + (eval-for-emacs): Don't use SLOT-VALUE on condition objects! + (inspect-bigger-piece-actions): Changed from DEFMETHOD to DEFUN. + (inspect-whole-thing-action): Likewise. + (inspect-show-more-action): Likewise. + (make-symbols-listing): Adds an explicit DEFGENERIC. + (menu-choices-for-presentation): Likewise. + + (make-symbols-listing (eql :classification)): Use `(loop for k + being EACH hash-key ...)' rather than `(loop for k being THE + hash-key)', to omit the justified style-warning from CLISP. + +2007-05-14 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp (package-names): Make sure to return a fresh list. + (fuzzy-find-matching-packages): Use PACKAGE-NAMES. + (list-all-package-names): Use PACKAGE-NAMES. + +2007-05-13 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-pretty-lambdas): Removed. If you really want + this, please use one of the external ressources that provide this; + for instance, `pretty-lambda.el', `pretty-greek.el', or even + `pretty-symbols.el'. For more information, please see + + http://www.emacswiki.org/cgi-bin/wiki/PrettyLambda + +2007-05-11 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp (fuzzy-find-matching-symbols): Modified to take + package nicknames into account. Previously, fuzzy completing on + nicknames did (except for some incidental cases) not work. Thanks + to Lu�s Oliveira and Attila Lendvai for pointing that out. + +2007-05-11 Tobias C. Rittweiler <tcr(a)freebits.de> + + Removed support for completing to the longest compound pre- and + suffix with the default completion method (C-c TAB, or just TAB on + the REPL), because it has been causing trouble all the time, but + didn't offer any real advantage besides niftiness. E.g.: + + previous behaviour: + + asdf:*com TAB => asdf:*compile-file--behaviour* + + now simply: + + asdf:*com TAB => asdf:*compile-file- + + For discussing on this subject, please see the mail with + message-id <87y7l53lch.fsf(a)freebits.de> that was posted to + slime-devel 2007-04-06, or alternatively: + + http://common-lisp.net/pipermail/slime-devel/2007-April/006087.html + + * swank.lisp (make-compound-prefix-matcher): New function. + Abstracted from COMPOUND-PREFIX-MATCH. + (compound-prefix-match): Use MAKE-COMPOUND-PREFIX-MATCHER. + (compound-prefix-match/ci/underscores): Removed. + + (longest-completion): Renamed to LONGEST-COMPOUND-PREFIX. Changed + to only return a compound prefix, instead of a concatenation of a + compound prefix and a compound suffix. Added an &optional + parameter to specify what delimeter the passed string is + compounded with. + (tokenize-completion): Takes additional parameter to specify the + delimeter for tokenization. + (longest-completion/underscores): Removed; not needed anymore. + (tokenize-completion/underscores): Likewise. + (untokenize-completion/underscores): Likewise. + + (completions): Slight docstring modification, also added an + examplary use case; use LONGEST-COMPOUND-PREFIX instead of + LONGEST-COMPLETION. + (completions-for-character): Use LONGEST-COMPOUND-PREFIX, and + MAKE-COMPOUND-PREFIX-MATCHER. + (completions-for-keyword): Use LONGEST-COMPOUND-PREFIX. + +2007-05-11 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp (apropos-symbols): Really use MAKE-REGEXP-MATCHER. + +2007-05-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp: Previously when using SLIME-APROPOS-PACKAGE, only + those symbols were considered whose home package matched the + given package; this would, however, prevent all those symbols from + being listed that are imported from another package, and then + exported again in the package they got imported into. (As an + example, SWANK:RESTART-FRAME is actually from SWANK-BACKEND.) + + (apropos-matcher): Renamed to MAKE-REGEXP-MATCHER. + (make-regexp-matcher): Changed to only match for a given regexp. + (apropos-symbols): Use MAKE-REGEXP-MATCHER. + +2007-05-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el: Fix macroexpanding on things like ",(loop ...)". + + (slime-sexp-at-point-for-macroexpansion): New function; like + SLIME-SEXP-AT-POINT-OR-ERROR, but fixes up some misbehaviour with + respect to macroexpansion. + (slime-eval-macroexpand, slime-eval-macroexpand-inplace): Use the + new function. + +2007-05-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el: Within the Slime Inspector, `S-Tab' will now also work + on X. Furthermore `Tab' and `S-Tab' will now correctly wrap + around the beginning and end of the buffer; priorly it'd hang on + the beginning with a message "Beginning of buffer", and would + require an additional `S-Tab'. + + (slime-inspector-mode-map): Attached `[backtab]' to + SLIME-INSPECTOR-PREVIOUS-INSPECTABLE-OBJECT, as Emacs translates + `S-Tab' to `Backtab' on X. + (slime-find-inspectable-object): New function; finds next or + previous inspectable object. + (slime-inspector-next-inspectable-object): Mostly rewritten. Use + SLIME-FIND-INSPECTABLE-OBJECT to make the code clearer. + +2007-04-19 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-backend.lisp (label-value-line): Add :newline as &key + argument; if true (the default) inserts a newline. + + * swank.lisp (inspect-for-emacs-list): Don't add a newline after + the last value of the list. + +2007-04-18 Marco Baringer <mb(a)bese.it> + + * swank.lisp (log-event): Setup the printer so that, no matter + what the global values of the *print-XYZ* variables, this function + works as expected. + (*debug-on-swank-error*): New variable. + (defpackage :swank): Export *debug-on-swank-error*. + (with-reader-error-handler): When *debug-on-swank-error* is + non-nil drop into a debugger. + (dispatch-loop): Idem. + +2007-04-17 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp: Instead of just having all the symbols of a package + listed alphabetically in the inspector page recently introduced + for that purpose, add a button to that page to group them by their + classification. + + (%package-symbols-container): New slot GROUPING-KIND. + (%make-package-symbols-container): New function; wraps around + %%MAKE-PACKAGE-SYMBOLS-CONTAINER, which will actually create the + structure. We need this, to make GROUPING-KIND an entirely + internal affair. + + (make-symbols-listing): New generic function to dispatch on + GROUPING-KIND. + (make-symbols-listing :symbol): Just the stuff that was priorly + wired into INSPECT-FOR-EMACS (%PACKAGE-SYMBOLS-CONTAINER). + (make-symbols-listing :classification): New; returns the passed + symbols grouped by their classification. + (inspect-for-emacs %package-symbols-container): Most code split + off into MAKE-SYMBOLS-LISTING. + +2007-04-17 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp (swank-compiler): Fix the return value to always be a + list of two elements even if the abort restart is invoked which + originally just returned NIL. (Which wouldn't play with the recent + change to use DESTRUCTURING-BIND in SLIME-COMPILATION-FINISHED.) + +2007-04-17 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp (inspect-for-emacs %package-symbols-container): + Revert Marco's change from 2007-04-08; he had the good idea of + adding a facility to jump to the relevant source line of a symbol, + but `M-.' is already bound to SLIME-FIND-DEFINITION in the + inspector, which is a nicer way of doing this alltogether. + +2007-04-16 Takehiko Abe <keke(a)gol.com> + + * swank-openmcl.lisp (accept-connection, find-external-format): + utf-8 support. + +2007-04-16 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-with-xref-buffer): Added missing , + +2007-04-16 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el: Pressing `q' in *compiler notes* after a `C-c C-k' or + `C-c M-k' would not probably restore the original window + configuration. Fix that. + + (slime-get-temp-buffer-create): New &key arg WINDOW-CONFIGURATION. + (slime-with-xref-buffer): Likewise. + + (slime-compilation-finished): New &optional arg WINDOW-CONFIG. + (slime-maybe-show-xrefs-for-notes): Likewise. + (slime-show-xrefs) Likewise. + (slime-maybe-list-compiler-notes): Likewise. + (slime-list-compiler-notes): Likewise. + + (slime-compilation-finished-continuation): Renamed to + SLIME-MAKE-COMPILATION-FINISHED-CONTINUATION. + + (slime-make-compilation-finished-continuation): Now takes two + args, the current buffer and optionally the current window config + to be restored. + + (slime-compile-file): Save current window configuration before + popping up the REPL for compilation output, pass it down. + (slime-easy-menu): Add entry for SLIME-UNTRACE-ALL. + +2007-04-16 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp (fuzzy-find-matching-packages): Fix a small typo that + prevented interpreting NIL as the argument TIME-LIMIT-IN-MEC to + mean an infinite time limit. This bug propagated up to explicit + calls to FUZZY-COMPLETIONS, like + (swank:fuzzy-completions "mvb" "COMMON-LISP") => (NIL, T) + + (format-fuzzy-completions): Renamed to FORMAT-FUZZY-COMPLETION-SET + + (format-fuzzy-completion-set): Accomodated to recent changes of + the return value of FUZZY-COMPLETIONS; changed the docstring to + make it explicit that this function is supposed to take the return + value of FUZZY-COMPLETION-SET. + + * slime.el (slime-compilation-finished): Don't use + MULTIPLE-VALUE-BIND for list destructuring, only because multiple + values happen to be implemented via lists in elisp! + (slime-fuzzy-completions-mode): Added an detailed explanation to + the docstring of how Fuzzy Completion works and how it'ss supposed + to be worked with. + (slime-fuzzy-explanation): Shortened to reference to + SLIME-FUZZY-COMPLETIONS-MODE for help on fuzzy completion. + (slime-fuzzy-choices-buffer): Set BUFFER-QUIT-FUNCTION to + SLIME-FUZZY-ABORT to make it correctly exit fuzzy completion when + pressing `Esc Esc Esc' (`M-Esc Esc'). + +2007-04-12 Nikodemus Siivola <nikodemus(a)random-state.net> + + * swank-sbcl.lisp (emacs-buffer-source-location): Add &allow-other-keys + to the descructuring of the source location plist in order to accept + :emacs-directory. + +2007-04-09 Marco Baringer <mb(a)bese.it> + + * swank.lisp (inspector-content-for-emacs): Look for refresh + keyword argument in :action links. + (inspect-whole-thing-action, inspect-show-more-action): Update for + new :action argument handling. + (inspect-for-emacs stream, inspect-for-emacs stream-error): Pass + :refresh nil on :action links. + (action-part-for-emacs): Set both lambda and refresh in the + *inspectee-actions* array. + (inspector-call-nth-action): *inspectee-actions* now holds both + the function and the boolean specifying whether to refresh or not. + + * swank-backend.lisp (inspect-for-emacs): Docstring update. + + * slime.el (slime-inspector-operate-on-point): Allow the action + calls to return nil. + +2007-04-08 Marco Baringer <mb(a)bese.it> + + * .cvsignore: Added *.lx64fsl (openmcl on linux fasls). + +2007-04-08 Marco Baringer <mb(a)bese.it> + + * swank.lisp (inspect-for-emacs): Added 'jump to source' action + for symbols in the new package-symbol browser. + +2007-04-08 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp: Implemented a new special inspector page for + displaying internal (external, &c) symbols that display + classification flags additionally to each symbol, similiar to the + content of a *Fuzzy Completion* buffer. Furthermore, added the + possibility to display all symbols that are /present/ in a + package. Combined with cleanup of the code parts in question. + + (symbol-status): New function. Returns the status of a symbol in a + given package (:internal, :external &c.) + + (symbol-external-p): Adapted to use new function SYMBOL-STATUS. + + (symbol-classification->string): New function. Converts a list of + classification flags into a concise string representation. + + (%package-symbols-container): New struct. We need a unique type to + dispatch in INSPECT-FOR-EMACS for the new inspector page, use this + as a wrapper structure. + + (inspect-for-emacs package): Reorganized to not cause too much eye + cancer; now with a saner maximum column width. Changed to make use + of new SYMBOL-STATUS, for code reuse. Also changed to make use of + new %PACKAGE-SYMBOLS-CONTAINER to let a new page pop up in Emacs + if the user wants to access the list of symbols of the package. + Added such a possibility to access all `present' symbols. + + (inspect-for-emacs %package-symbols-container): New method. + Displays all symbols wrapped up in the container structure + combined with their classification flags as determined by + CLASSIFY-SYMBOL. + +2007-04-08 Lu�s Oliveira <loliveira(a)common-lisp.net> + + * swank-backend.lisp (compute-sane-restarts): New interface. + * swank-clisp.lisp: Fix tabs and trailing whitespace. + (compute-sane-restarts): Implement new interface. + +2007-04-08 Takehiko Abe <keke(a)gol.com> + + * swank-openmcl.lisp (xref-locations): + +2007-04-08 Marco Baringer <mb(a)bese.it> + + * swank.lisp (fuzzy-completion-set): Use two check-type forms + instead of a place like (values limit time-limit-in-msec). While + sbcl seems to accept this form openmcl doesn't and it's not clear + from the spec that this is allowed. + +2007-04-07 Harald Hanche-Olsen <hanche(a)math.ntnu.no> + + * slime.el (sldb-mode-map): Added key definition for follow-link. + +2007-04-06 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp: Making fuzzy completion regard the time limit + correctly. Also make it properly use microseconds as time + granularity and inform the Emacs side if the time limit has + exhausted. Additionally, over all minor and cosmetic changes: + + (fuzzy-completions, fuzzy-completion-set): Returns now + additionally a flag indicating whether the time limit has + exhausted under the hood. Accomodated docstring accordingly. + + (fuzzy-create-completion-set): Changed to correctly catch and + propagate the remaining time limit to the actual match functions, + and return once time limit has exhausted. Some aesthetical code + reorganization. + + (get-real-time-in-msecs): New function. + + (fuzzy-find-matching-symbols, fuzzy-find-matching-packages): + Correctly regard the time limit. Use new function + GET-REAL-TIME-IN-MSECS for that purpose. Return the remaining + time limit as second value. + + * slime.el (slime-fuzzy-complete-symbol): Accomodated to deal with + the additionally returned flag of SWANK:FUZZY-COMPLETIONS. Pass + the flag by. + (slime-fuzzy-choices-buffer): Pass interruption flag by. + (slime-fuzzy-fill-completions-buffer): If time limit has exhausted + during completion retrieval, show an informational indication as + last entry in *Fuzzy Completion*. + (slime-fuzzy-last): New variable. To hold the last real completion + choice previous to the (possible) Time Limit Exhausted information. + (slime-fuzzy-next): Accomodated to not go beneath SLIME-FUZZY-LAST. + +2007-04-06 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp (tokenize-symbol, tokenize-symbol-thoroughly): + Previously these functions said a string representing a symbol is + internal exactly if it contained "::" as substring. Now they say + additionally so for symbols without any package identifier, as + they are internal to am implicit current package. (Otherwise + will break fuzzy completion.) + + (tokenize-symbol): Added docstring. + + * swank.lisp (format-completion-result): Fixed formation + for the case that PACKAGE-NAME is NIL but INTERNAL-P is T. + +2007-04-06 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp: Making fuzzy completion semantically right from a + user perspective. As an example on SBCL, "sb:with- C-c M-i" will + display all exported "with"-style macros in all sb-* packages from + now on. :) + + (parse-completion-arguments): Replacing with a semantically-sound + implementation, as the previous one was a bit confused. Clarifying + docstring. Adding commentary table of various constellations of + returned values for thorough explanation. + + (carefully-find-package): Removed. Obsolete by above change. + + (defstruct fuzzy-matching): Introduced to make internally-used + datastructure explicit. Distinguishing ``completion chunks'' + between those pertaining to the symbol itself and those to the + package identifier. + + (convert-fuzzy-completion-result): Renamed to + FUZZY-CONVERT-MATCHING-FOR-EMACS. + + (fuzzy-convert-matching-for-emacs): Accomodating for the new + datastructure. Only the chunks pertaining to the symbol itself are + fixed up positionally, the package-chunks are untouched. + Necessary for letting package identifiers be highlighted within + *Fuzzy Completions* in cases like "sb:with- C-c M-i." + + (fuzzy-completion-set): Taking out most code to become new + function FUZZY-CREATE-COMPLETION-SET. + + (fuzzy-create-completion-set): Doing all the hard work. Crux of + this changeset. so to speak. Largly rewritten to accomodate all + different cases of PARSE-COMPLETION-ARGUMENT. + + (fuzzy-find-matching-symbols, fuzzy-find-matching-packages): + Accomodating to new datatstructure FUZZY-MATCHING. Adapting + docstring accordingly. + + * swank-backend.lisp: Export WITH-STRUCT. + + * swank.lisp (eval-for-emacs, fuzzy-completions): + Various trivia like fixing spelling and indentation. + +2007-04-06 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-fuzzy-highlight-current-completion): Fix + off-by-one error that causes the currently selected + completion in the *Fuzzy Completion* buffer be highlighted + one char too far. + +2007-04-06 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank.lisp: Cleanup of parts of the fuzzy completion code. + Additionally a couple of enhancements. As follows: + + (fuzzy-completions, fuzzy-completion-selected): Minor + stylistic and clarifying modifications of the docstrings. + + (fuzzy-find-matching-symbols): Huge code reorganization. + Organizing relevant code into local function TIME-EXHAUSTED-P, + renaming local function SYMBOL-MATCH to PERFORM-FUZZY-MATCH, + making previously required argument EXTERNAL to new &key + argument :EXTERNAL-ONLY, clarifying docstring. + + (fuzzy-find-matching-packages): Making its return value + conformant to that of FUZZY-FIND-MATCHING-SYMBOLS, i.e. + instead of returning, among others, a package's name as + string, it now returns a symbol representing the package. + Accomodates the docstring accordingly. + + (fuzzy-completion-set): Minor typographical fix in docstring. + Changing local function CONVERT to use MAP-INTO instead of + doing it essentially manually. Accomodating to changes of + FUZZY-FIND-MATCHING-SYMBOLS, resp. -PACKAGES. + + (fuzzy-completion-set): Additional new feature: + The returned completions are sorted alphabetically by the + matched completion string before sorted by its score. + Affects especially the list of all possible completions when + the user hits fuzzy-completion on an empty string within Emacs; + also makes the potential limitness of the listed completions + clearer to the end user of SLIME. + + (classify-symbol): New function. Returns a list with keywords + that classifies a given symbol. (E.g. :BOUNDP, :MACRO &c) + Supersedes parts of CONVERT-FUZZY-COMPLETION-RESULT, + implementing them in a more straightforward and proper way; + removes prior KLUDGE in that part of the original function. + + (convert-fuzzy-completion-result): The above changes made + it possible to simplify this function drastically. Now uses + the newly introduced function CLASSIFY-SYMBOL. + + * slime.el: Minor stylistic changes. Additionally: + (slime-fuzzy-insert-completion-choice): + (slime-fuzzy-fill-completions-buffer) : Adding use of the + :PACKAGE classification flag returned by SWANK:FUZZY-COMPLETIONS. + This flag is called "p". + +2007-04-06 Neil Van Dyke <neil(a)neilvandyke.org> + + * slime.el (sldb-insert-frame): Added mouse-face to frame label + and expression in Backtrace. + (sldb-insert-frames): Added mouse-face to "--more--" label in + Backtrace. + +2007-04-06 Michael Weber <michaelw+slime(a)foldr.org> + + * slime.el (slime-call-defun): insert the closing parenthesis for + the form. + +2007-04-06 Marco Baringer <mb(a)bese.it> + + * swank-openmcl.lisp (package swank-mop): Added + slot-makunbound-using-class. + +2007-03-29 Nikodemus Siivola <nikodemus(a)random-state.net> + + * swank-sbcl.lisp (swank-compile-string): save the original + directory into the source plist as :emacs-directory. + (make-definition-source-location): use the :emacs-directory from + the source plist and guess-readtable-for-filename to determine the + correct readtable for string-compiled definitions. + +2007-03-29 Nikodemus Siivola <nikodemus(a)random-state.net> + + * swank.lisp (*macroexpand-printer-bindings*): add *print-lines* + to defaults (NIL). + (find-definitions-for-emacs): use unless instead of cond. + +2007-03-25 Douglas Crosher <dcrosher(a)common-lisp.net> + + * slime.el (with-selected-window): define for compatibility with + Emacs 21. + +2007-03-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (menu-choices-for-presentation): Offer a + "disassemble" menu item for functions. + +2007-03-24 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-read-port-and-connect): Fix race condition: + retry one more time if the port file is empty. Pop up the debugger + on other errors. + (slime-attempt-connection): Moved to toplevel. + (slime-timer-call): New. Used by slime-attempt-connection. + (slime-cancel-connect-retry-timer): New. + (slime-abort-connection): Use it. + (slime-repl-insert-prompt): Use insert-before-markers. This fixes + some redisplay problems, but I don't know why. Also: remove the + timer for async output. + (slime-repl-move-output-mark-before-prompt): Removed. + (slime-repl-save-merged-history): Use with-temp-message. + (slime-goto-location-buffer): Support Zip files. + (sldb-quit): Don't print "Evaluation aborted". + +2007-03-22 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-scratch-buffer): Respect the syntax text + properties of presentations. + +2007-03-21 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (lookup-presented-object): The presentation id of + frame locals now includes the thread id; ignore it for now. + + * slime.el (slime-copy-presentation-at-mouse-to-point): Manually + invoke the after-change function, so that the presentation overlay + is created even if we paste to non-REPL buffers. + (slime-menu-choices-for-presentation): Evaluate + menu-choices-for-presentation-id in the right buffer, thus in the + right Lisp thread. Reported by Attila Lendvai. + (slime-menu-choices-for-presentation): Show the id of the presentation. + (sldb-insert-locals): Include the thread id in the presentation id. + +2007-03-21 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-repl-eval-string, slime-repl-insert-result): + Support the presentation-less old protocol. + (slime-goto-location-position): Use column number if available. + +2007-03-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (completion-output-symbol-converter): Fix completion + for mixed-case symbols that need escaping in readtable-case + :upcase or :downcase. + + * slime.el (slime-copy-presentation-at-mouse-to-point) + (slime-copy-presentation-at-mouse-to-kill-ring): New commands. + (slime-menu-choices-for-presentation): Change interface. New + menu options, Copy to kill-ring, Copy to point. + (slime-presentation-menu): Change call to + slime-menu-choices-for-presentation. + +2007-03-20 Takehiko Abe <keke(a)gol.com> + + * swank-openmcl.lisp (hash-table-weakness): fix typo + +2007-03-14 Christophe Rhodes <csr21(a)cantab.net> + + * slime.el (slime-search-suppressed-forms): handle multiple + conditionals on the same line. + +2007-02-26 Nikodemus Siivola <nikodemus(a)random-state.net> + + * swank.lisp (inspect-for-emacs): Add support for inspecting + non-decodable float entities like NaNs and infinities. + +2007-02-25 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-backend.lisp (inspect-for-emacs): Remove reference to + inexistent argument from docstring. + +2007-02-25 Harald Hanche-Olsen <hanche(a)math.ntnu.no> + + * slime.el (slime-init-keymaps): Use vectors when defining keys, + because e.g. (define-key (string ?\C-c) ...) doesn't work in the + emacs-unicode-2 branch. Some strings are still there. + +2007-02-25 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-delete-swank-port-file): Don't use + display-warning; that's not available everywhere. + (slime-repl-update-banner): Insert the date only if the buffer is + empty. + (slime-list-compiler-notes): Fetch the notes only if called + interactively. + (slime-set-query-on-exit-flag): New function, to avoid compiler + warnings about obsolete function process-kill-without-query. + (slime-defun-if-undefined): Perform the test at runtime not at + compile time. Reported by Lennart Staflin. + + * swank.lisp (guess-package): Renamed from + guess-package-from-string. + (set-package): Use it. + +2007-02-22 Juho Snellman <jsnell(a)iki.fi> + + * slime.el (slime-start-lisp): Don't cd if no directory was specified. + (slime-maybe-start-lisp): Pass directory argument to slime-start-lisp + also in other cond branch. + (slime-restart-sentinel): Pass a NIL directory to slime-start-lisp. + +2007-02-21 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-start): Added :directory argument and pass it to + slime-maybe-start-lisp. + (slime-maybe-start-lisp): Added directory argument and pass it to + slime-start-lisp (but not slime-reinitialize-inferior-lisp-p) + (slime-start-lisp): Added directory argument. Used to set buffer's + directory before starting the inferior lisp. + +2007-02-17 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-find-tag-if-tags-table-visited): New function. + (slime-edit-definition-fallback-function): Offer it as a value + for customization. + +2007-02-05 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (sldb-insert-locals): Repair presentation markup of + frame locals. + +2007-02-04 Antonio Menezes Leitao <aml(a)gia.ist.utl.pt> + + * swank-lispworks.lisp (dspec-file-position): Bind + *compile-file-pathname*, *compile-file-truename*, *load-pathname* + and *load-truename* in dspec-file-position. + +2007-02-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-write-string): When writing a :repl-result, + update the slime-output-end marker for the purpose of asynchronous + output (when *use-dedicated-output-stream* is true). + Reported by Madhu <enometh(a)meer.net>. + +2007-02-03 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-delete-swank-port-file): Fix typo in + warning message. + +2007-02-02 Marco Baringer <mb(a)bese.it> + + Warn, as opposed to bailing out with an error, when deleting the + port file fails. Patch by: Samium Gromoff + <_deepfire(a)feelingofgreen.ru> + + * slime.el (slime-delete-swank-port-file): New function. + (slime-inferior-connect): Use slime-delete-swank-port-file. + (slime-read-port-and-connect): Use slime-delete-swank-port-file. + +2007-01-31 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-repl-update-banner): Restore animation. + (slime-startup-animation): restore. + +2007-01-30 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-complete-symbol-function): Restore old default. + (set-keymap-parents): Deleted. + (slime-startup-animation): Deleted. + (slime-read-from-minibuffer): Don't use defun*. + (slime-repl-terminate-history-search): New. + (slime-repl-next-matching-input): Use it. + + * slime-autoloads.el: New file. + +2007-01-29 Sean O'Rourke <sorourke(a)cs.ucsd.edu> + + * slime.el (slime-start): Continue even if the user, after + prompting, didn't recompile the stale .elc file. + (slime-urge-bytecode-recompile) [xemacs]: Abort immediately if the + user doesn't want to continue. + (slime-recompile-bytecode): Don't use byte-compile-warning-types; + it may not exist in XEmacs. + +2007-01-24 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (sldb-recenter-region): Use count-screen-lines instead + of count-lines. + + * swank.lisp (unparse-name): New function. + (list-all-package-names): Use it. This fixes a bug related to + readtable-case and makes package name completions look prettier. + Suggested by Harald Hanche-Olsen <hanche(a)math.ntnu.no>. + +2007-01-24 Bill Clementson <billclem(a)gmail.com> + + * slime.el (slime-call-defun): Put the docstring before + the (interactive) form so that "C-h f slime-call-defun" will + return it. + + * slime.el (slime-scratch-mode-map): Changed parent keymap to + lisp-mode-map to prevent unnecessary duplication of slime-mode-map + bindings and so that lisp-mode-map key bindings are present in the + slime scratch buffer. Change identified by Ariel Badichi. + +2007-01-20 Luke Gorrie <luke(a)synap.se> + + * slime.el (slime): Use COMMAND and CODING-SYSTEM parameters + Previously they were ignored. + +2007-01-17 Christian Lynbech <christian.lynbech(a)ericsson.com> + + * slime.el (slime-init-command): Use expanded files when writing + the LOAD form for swank. + +2007-01-14 Helmut Eller <heller(a)common-lisp.net> + + * slime.el: Cleanups for the repl history code. + (slime-repl-mode-map): Don't shadow M-C-d. + (slime-repl-history-replace): Simplified. + (slime-repl-history-search-in-progress-p): New. + (slime-repl-position-in-history): If there's no match return + out-of-bound positions instead of nil. + (slime-repl-add-to-input-history): Never modify the argument. + (slime-repl-previous-input): Renamed from + slime-repl-previous-input-starting-with-current-input. + (slime-repl-next-input): Renamed from + slime-repl-next-input-starting-with-current-input + (slime-repl-forward-input): Renamed from slime-repl-next-input. + (slime-repl-backward-input): Renamed from + slime-repl-previous-input. + (slime-repl-history-pattern): Renamed from + slime-repl-matching-input-regexp. + (slime-repl-delete-from-input-history): Simplified. + + (slime-repl-history-map) + (slime-repl-history-navigation-neutral-commands) + (slime-repl-jump-to-history-item) + (slime-repl-previous-or-next-input) + (slime-repl-starting-with-current-input-regexp) + (slime-repl-continue-search-with-last-pattern) + (slime-repl-previous-or-next-matching-input): Deleted. + + (sldb-list-locals, sldb-list-catch-tags): Deleted. Aren't of much + use anymore. + +2007-01-12 Helmut Eller <heller(a)common-lisp.net> + + * swank-clisp.lisp: Better classification on frames on the stack. + Make variables in eval frames accessible to the debugger. + (frame-type, *frame-prefixes*, frame-to-string, is-prefix-p) + (frame-string-type, boring-frame-p): New. + (%frame-count-vars, %frame-var-name, %frame-var-value) + (frame-venv, next-venv, venv-ref, %parse-stack-values): Replaces + old frame-do-venv. + (extract-frame-line, extract-function-name, split-frame-string) + (string-match): New code to print frames. + (frame-locals, frame-var-value): Use the new stuff. + + (inspect-for-emacs): Fix various bugs. + + * swank-loader.lisp (compile-files-if-needed-serially): Don't wrap + everything in a compilation unit. If we abort on load errors and + it is confusing to see compiler warnings after the abort message. + (handle-loadtime-error): CLISP's format implements ~< differently + as everybody else, so use a explicit pprint-logical-block instead. + + * swank.lisp (list-all-systems-in-central-registry): Don't + reference asdf directly, that leads to read errors in some + systems. + +2007-01-12 Juho Snellman <jsnell(a)iki.fi> + + * slime.el (slime-read-expression-map): Switch the slime-mode-map + and minibuffer-local-map back the way they were. The previous change + was made due to a misunderstanding, caused by a keybinding for + [(return)] apparently being more specific than one for (kbd "RET"), + even when the former is in a parent keymap and the latter in the + child. + +2007-01-12 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (handle-request): Use 'abort as restart name, but + bind *sldb-quit-restart* to the restart returned by find-restart. + Also use a slighly friendlier message, because newbies seem to + invoke the ABORT restart instead of pressing q in the debugger. + +2007-01-12 Edi Weitz <edi(a)agharta.de> + + * slime.el (slime-find-asd): Remove file extension. + + (slime-read-system-name): Use SWANK:LIST-ASDF-SYSTEMS. + + * swank.lisp (list-all-systems-in-central-registry): Use only + pathname name. + + (list-all-systems-known-to-asdf): New function. + + (list-asdf-systems): New function. + +2007-01-12 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-keys): Remove binding of M-*, restore binding of + M-,. + +2007-01-11 Edi Weitz <edi(a)agharta.de> + + * slime.el (slime-repl-test-system, slime-repl-test/force-system): + New REPL shortcuts. Patch by Kevin Rosenberg + <kevin(a)rosenberg.net>. + +2007-01-11 Juho Snellman <jsnell(a)iki.fi> + + * slime.el (slime-read-expression-map): restore tab completion in + the minibuffer. Switch the slime-mode-map and minibuffer-local-map + around, so that the minibuffer binding for return takes precedence + over the slime-mode one. + +2007-01-11 Marco Baringer <mb(a)bese.it> + + * swank.lisp (inspect-for-emacs integer): Don't die if the integer + can't be expressed as a float. Patch by Ariel Badichi + <abadichi(a)bezeqint.net>. + + * slime.el (slime-keys): Removed binding of M-, + +2007-01-11 Helmut Eller <heller(a)common-lisp.net> + + * slime.el: Some cleanups for the debugger code: add some outline + sections and docstrings. + + (sldb-setup): Always display the beginning of the condition + text. Previously, we always showed the beginning of the backtrace. + + (sldb-prune-initial-frames): Do what the docstring says. Reverted + to Luke's version. + + (sldb-dispatch-extras): Fix typo. + + (sldb-insert-restarts, sldb-insert-frames) + (sldb-insert-frame, sldb-fetch-more-frames) + (sldb-toggle-details, sldb-show-frame-details) + (sldb-insert-locals): Simplified. + (sldb-frame-details): New. + + (slime-save-coordinates, slime-coordinates) + (slime-restore-coordinate, slime-count-lines): New macro and its + helpers. + (sldb-recenter-region): Renamed from slime-maybe-recenter-region. + + (sldb-enable-styled-backtrace, sldb-show-catch-tags) + (sldb-highlight): Deleted. Seem to be obsolete. + (sldb-add-face): Removed, because it is now the same as + slime-add-face. + + (sldb-help-summary): Deleted. The docstring for sldb-mode is + already pretty terse. + (define-sldb-face): Renamed from def-sldb-face. + + * swank-sbcl.lisp, swank-cmucl.lisp (condition-extras): Fix typo + +2007-01-10 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (*sldb-printer-bindings*): Add *print-right-margin*. + (debug-in-emacs): Bind *sldb-printer-bindings* here ... + (backtrace, debugger-info-for-emacs, frame-locals-for-emacs): + ... and remove redundant bindings here. + +2007-01-10 Attila Lendvai <attila.lendvai(a)gmail.com> + + * slime.el: FIX: set-keymap-parents for GNU Emacs was bogus, fixed + by Ariel Badichi. + +2007-01-09 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-repl-merge-histories): Use (setf (gethash ...) + instead of puthash, for Emacs 20. + +2007-01-09 Juho Snellman <jsnell(a)iki.fi> + + SBCL 1.0.1.15 supports restart-frame natively, and uses a different + debug catch tag interface than earlier versions. + + * swank-sbcl (sbcl-with-restart-frame): New function, detects SBCL + 1.0.1.15 or later. + (return-from-frame): Another version for 1.0.1.15, using + sb-debug:unwind-to-frame-and-call + (restart-frame): Another version for 1.0.1.15, using + sb-debug:unwind-to-frame-and-call + +2007-01-07 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (open-streams): Don't pass nil to make-fn-streams; + use a dummy function as workaround. Both arguments must be + functions and CMUCL checks the types. + +2007-01-06 Attila Lendvai <attila.lendvai(a)gmail.com> + + * slime.el: Added set-keymap-parents when not available (GNU + Emacs). Result: slime bindings while reading expressions from the + minibuffer. + + * slime.el, swank.lisp: FIX: slime-insert-possibly-as-rectange and + sldb stuff on newer emacsen + +2007-01-04 Attila Lendvai <attila.lendvai(a)gmail.com> + + * slime.el: Added slime-insert-possibly-as-rectangle and use it + when inserting things here and there. The effect of this is that + multi-line strings coming from swank (e.g. stuff in sldb) are + inserted with insert-rectangle, so they are properly indented. + + * swank.lisp: FIX: sort is destructive, call copy-seq at a few + places. FIX: bind *sldb-printer-bindings* also in + frame-locals-for-emacs. + +2007-01-03 Attila Lendvai <attila.lendvai(a)gmail.com> + + * swank.lisp: FIX: drop extra "Slots: " from standard-object's + inspector presentation + + * swank.lisp: FIX: keyword symbols keep their : when travelling + from swank to slime + + * slime.el: FIX: older Emacsen have no line-number-at-pos. + + * slime.el: Convert some minibuffer reading defun's to defun* and + use keywords. Support extra arguments. + + * slime.el: Use set-parent-keymaps when available (xemacs only for + now) when setting up slime-read-expression-map. The effect of this + is that the minibuffer will have all the slime-mode-map keys where + minibuffer-local-map is not overriding. + + * slime.el, swank.lisp: Handle better the case when swank can not + read anything from the string sent to be inspected. Only bring up + the debugger when the inspect command is prefixed. + +2006-12-31 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Restore the nested-presentations feature. + + * present.lisp (slime-stream-p): Allow sending presentations to + the repl-results stream. + (make-presentations-result): Removed. + (send-repl-results-to-emacs): New. + + * swank.lisp (connection): New slot repl-results (a stream). + (make-output-function-for-target): New. + (open-streams): Use it here to also create a stream for REPL results. + (initialize-streams-for-connection): Store the stream. + +2006-12-29 Edi Weitz <edi(a)agharta.de> + + * slime.el (slime-find-asd, slime-read-system-name): Only offer + initial input if system is really in central registry. + +2006-12-29 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Simplify the REPL-results protocol. The results are now printed + using special :WRITE-STRING events from the Lisp side. + + * slime.el (slime-repl-insert-prompt): Don't insert a result, only + the prompt. + (slime-repl-insert-result): Removed. + (slime-repl-eval-string, slime-repl-show-abort) + (slime-repl-set-package, slime-output-buffer) + (slime-repl-update-banner): Change all callers. + (slime-dispatch-event): Event :WRITE-STRING gets an + optional argument TARGET, which controls where the string is + inserted. + (slime-write-string): Handle targets NIL (regular process output) + and :REPL-RESULT. + + * swank.lisp (make-presentations-result): Removed. + (send-repl-results-to-emacs): New function, sends :WRITE-STRING events. + (listener-eval): Use it here instead of make-presentations-result. + +2006-12-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Performance improvement for slime-autodoc-mode, in particular when + there are REPL results that are long lists. + + * slime.el (slime-repl-mode-beginning-of-defun) + (slime-repl-mode-end-of-defun): New. + (slime-repl-mode): Use them as beginning-of-defun-function and + end-of-defun-function. + (slime-enclosing-operator-names): Bind + parse-sexp-lookup-properties to nil, don't parse more than 20000 + characters before point, don't determine exact argument positions + larger than 64. Byte-compile this function. + +2006-12-24 Attila Lendvai <attila.lendvai(a)gmail.com> + + * slime.el, swank.lisp: Added customizable dwim lookup hook + support for inspect + + * doc/slime.texi: Small doc fixes by Alfredo Beaumont + + * swank.lisp: Change the order to [set value] [make unbound]. Sort + slot names in the inspector + +2006-12-23 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank-clisp.lisp (make-weak-key-hash-table) + (make-weak-value-hash-table): Implement for CLISP, so that the + REPL results history does not cause "memory leaks". + + * slime.el (slime-inspect): Add a dwim-mode keyword argument, move + all input handling into the interactive spec. Restore the + behavior of slime-inspect when point is within a presentation (no + prompting, no DWIM). + (slime-inspect-presentation-at-mouse): Don't do DWIM here, so the + presentation-retrieval expression does not end up on the inspector + stack. + (slime-inspector-position): New. + (slime-inspector-operate-on-point, slime-inspector-reinspect): Use + it here to make it work on GNU Emacs too. + (slime-open-inspector): Fix row-col addressing at end of buffer. + +2006-12-20 Attila Lendvai <attila.lendvai(a)gmail.com> + + * slime.el: FIX: inspecting presentations from the right click + menu broke in the inspect refactor + + * slime.el: FIX: slime-fuzzy-target-buffer-completions-mode's + keymap must always precede other keymaps + + * slime.el, swank.lisp: Extend :write-string with and &optional + presentation id and use this in present-in-emacs + + * swank.lisp: Added present-in-emacs that prints a presentation of + the given object in the repl + + * swank.lisp: Return the inspected object when inspecting from the + lisp side. + + * swank.lisp: Turn off right margin for restart printing, too + +2006-12-19 Attila Lendvai <attila.lendvai(a)gmail.com> + + * HACKING: Added useful init.el piece into HACKING about + update-change-log + + * swank.lisp: In all-slots-for-inspector pad slot names to be + equal length, so the result is more readable + + * slime.el: Fix slime-insert-presentation to handle multi-line + presentations better (use insert-rectangle) + + * swank.lisp: Properly bind *sldb-printer-bindings* and turn off + right margin while printing stuff in sldb + + * slime.el: Smarten up the sldb heuristic that drops swank frames + + * swank-allegro.lisp, swank-backend.lisp, swank-openmcl.lisp, + swank-sbcl.lisp, swank.lisp: Added hash-table-weakness and use it + in hash-table-inspecting + + * swank.lisp: Hashtable inspecting: added [clear hashtable] + and [remove entry] actions + + * slime.el, swank.lisp: FIX dwim inspecting to handle (setf + some-fun) functions, too + + * slime.el: FIX: slime-sexp-at-point for foo::|bar::baz| + + * slime.el: FIX: Properly keep track of slime-buffer-package in + the inspector + + * swank.lisp: Small: get rid of notes and warnings + + * slime.el, swank.lisp: Added dwim-mode to slime-inspect that + tries to be smart unless prefixed + + * slime.el: Make slime-fuzzy-complete-symbol the default in the + belife that it's better for new users + + * swank.lisp: Add (expt 1.2 length) higher scores for longer + matches in fuzzy completion. A good example: puts "make-instance" + before "make-string-input-stream" while completing "make-ins" + + * slime.el: Set slime-fuzzy-completion-in-place enabled by default + + * slime.el: Added (cons row col) addressing to + slime-open-inspector, use in slime-inspector-operate-on-point + + * slime.el: FIX: operate the inspector in the debug thread when + started from sldb + + * slime.el: Convert some inspector defuns to defun* and use + keywords. Other minor cleanups. + +2006-12-18 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-region-for-defun-at-point): end-of-defun and + beginning-of-defun modify match-data, added a save-match-data to + prevent this from affecting callers of + slime-region-for-defun-at-point. + +2006-12-15 Edi Weitz <edi(a)agharta.de> + + * swank-lispworks.lisp (make-weak-key-hash-table): Weak hash + tables for Lispworks. + (make-weak-value-hash-table): Ditto. + +2006-12-14 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (*sldb-printer-bindings*): *PRINT-LINES* is in + effect only if *PRINT-PRETTY* is non-NIL, so it better to enable + the pretty printer. Suggested by Madhu <enometh(a)meer.net>. + + * slime.el (slime-expand-abbreviations-and-complete): Emacs + `choose-completion' (choosing a completion from the *Completions* + buffer) always replaces text upto (point). So the code which + figures out an `unambiguous-completion-length' and places the + point there in `slime-expand-abbreviations-and-complete' causes + problems: the replacement text gets garbled. Get rid of the bogus + `unambiguous-completion-length'. Patch by Madhu <enometh(a)meer.net> + + * swank-cmucl.lisp (remove-gc-hooks): The variables + EXT:*GC-NOTIFY-AFTER* and EXT:*NOTIFY-BEFORE* should hold + functions and should be NIL. This affects the function + REMOVE-GC-HOOKS in swank-cmucl.lisp which sets them to + NIL, (should one happen to use it). Set them back to the original + parameters. Patch by Madhu <enometh(a)meer.net> + + * slime.el (slime-repl-output-mouseover-face): Fix a pair of extra + parens. Patch by Madhu <enometh(a)meer.net> + +2006-12-14 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-search-buffer-package): Remove Xemacs special + casing. There's already a compatibility defun for + match-string-no-properties. + +2006-12-13 Attila Lendvai <attila.lendvai(a)gmail.com> + + * swank.lisp: FIX: fuzzy completion for M-V-B. Fix by Madhu. + +2006-12-12 Nikodemus Siivola <nikodemus(a)random-state.net> + + * swank.lisp (inspect-for-emacs integer): Pad the hex formatted + value to eight digits, "Code-char:" instead of "Corresponding + character:", "Integer-length:" instead of "Length:", + "Universal-time:" instead of "As time". + (inspect-object): Use TYPE-FOR-EMACS instead of TYPE-OF. + (inspect-in-emacs): New function, analogous to ED-IN-EMACS. + + * swank-backend.lisp (type-for-emacs): New generic function, + defaults to TYPE-OF for non-integers, and returns FIXNUM or BIGNUM + for integers. + + * slime.el (destructure-case): Indicate in the error message that + it was the Elisp destructure-case that failed to avoid confusion. + (slime-check-eval-in-emacs-enabled): More verbose error message. + +2006-12-11 Attila Lendvai <attila.lendvai(a)gmail.com> + + * swank.lisp: Added [set value] command for slot inspecting + + * slime.el: Work on repl history navigation, restore old M-p/M-n + behaviour due to #lisp demand + + Also print the current regexp in the minibuffer messages. M-p/M-n + takes the repl input up to the point not the entire input as it + did before. + slime-repl-previous/next-input-starting-with-current-input: new + names for the old M-p/M-n commands History navigation commands + jump to the end of buffer when point is before the prompt. + + * slime.el: Fix/smarten up temp-buffer-quit + + Now it tries its best to remember the original window config and + restore it at slime-temp-buffer-quit unless it was changed + meanwhile. IOW, fix "q" after macroexpand in a macroexpand buffer + not closing the temp window. + Also fix the compiler notes usage of the temp buffer. + + * swank-backend.lisp, swank.lisp: + Added inspect-slot-for-emacs to let users customize it. + + Use all-slots-for-inspector everywhere, render link to both the + effective and direct slots when both are available. Dropped + slot-value-using-class-for-inspector and friends. Added + slot-makunbound-using-class to the swank-mop package and added + a [make-unbound] action to the standard slot presentation. + + * slime.el: FIX: slime-symbol-name-at-point for symbols like + foo::|bar::baz| + + * .cvsignore, swank.lisp: FIX: Drop #\. and add #\, to escaped + symbol chars + + * slime.el: Added slime-repl-delete-from-input-history that + deletes the current history entry when no input is supplied + + * slime.el: slime-repl-kill-input kills the entire input when + point is at the prompt and resets the history navigation state + + * slime.el: + Use a hashtable to remove duplicates in slime-repl-merge-histories + +2006-12-07 Marco Baringer <mb(a)bese.it> + + * swank.lisp (init-inspector): Added eval parameter. If NIL we + don't eval FORM but limit our selves to cl:read'ing it and + inspecting that value. + + * slime.el (slime-inspect): If a prefix argument is provided pass + :eval nil to swank:init-inspector. + +2006-12-07 Paul Collins <paul(a)briny.ondioline.org> + + * hyperspec.el (common-lisp-hyperspec): Strip all text properties + from the symbol-at-point to avoid problems with read-only text. + +2006-12-06 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-search-buffer-package): Don't call + match-string-no-properties if it's not defined (as is on some + xemacs') + (slime-repl-clear-buffer): Added optional prefix argument + specifying how many lines to leave. + +2006-12-06 Johan Bockg�rd <bojohan+sf(a)dd.chalmers.se> + + * swank.lisp (fuzzy-completion-set): Don't mix for clauses and + body clauses in loop. + +2006-12-05 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (create-swank-server): Removed. Use create-server + instead. + + * slime.el (slime-first-change-hook): Don't do anything if buffers + file doesn't exist. + (slime-start, slime-set-connection-info): Add support for a + :init-function which is called after the usual initialization of the + connection is completed. + + * swank-source-file-cache.lisp (buffer-first-change): Always + return nil and remove the now redundant test with probe-file. + + * swank-backend.lisp (guess-external-format): Return nil if the + file can't be opened. Previusly we wrongly read from stdin. + +2006-12-05 Juho Snellman <jsnell(a)iki.fi> + + Real xref support for SBCL (requires SBCL 1.0.0.18). + + * swank-sbcl.lisp (who-calls): New function, fetch xref data from + sb-introspect. + (who-binds): Ditto. + (who-sets): Ditto. + (who-references): Ditto. + (who-macroexpands): Ditto. + (defxref): New macro, create the above functions. + (source-location-for-xref-data): New, map from sb-introspect xref + format to the Swank xref format. + (sanitize-xrefs): Map PCL method names to something more readable. + (string-path-snippet): New function, finds a more accurate source + snippet for definition source locations which have both an + :emacs-string and a full source path available. Otherwise the xref + location would point to the toplevel form rather than the exact + form for functions compiled with C-c C-c. + (source-file-position): New function, somewhat like + source-path-file-position but uses the source-file cache, handles + missing form-paths more gracefully. + (make-definition-source-location): Use the above two functions. + (sbcl-with-xref-p): New function, detect whether SBCL has xref support + for backwards compability. + +2006-11-26 Juho Snellman <jsnell(a)iki.fi> + + * swank-source-file-cache.lisp (buffer-first-change): Check + whether a file exists before trying load it into the source cache. + +2006-11-26 Juho Snellman <jsnell(a)iki.fi> + + Restore the way M-n and M-p used to work in the REPL. (cherry-picked + from a patch with other changes, sent by Attila Lendvai). + + * slime.el (slime-repl-previous-input-starting-with-current-input) + (slime-repl-next-input-starting-with-current-input): New functions, + work like the old slime-repl-previous-input / next-input. + (slime-repl-matching-input-regexp): Restore old version. + (slime-repl-mode-map): Bind s-r-p-i-s-w-c-i and s-r-n-i-s-w-c-i + to M-p and M-n respectively. slime-repl-previous-input and + slime-repl-next-input are still accessible with C-up / C-down. + +2006-11-25 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-repl-read-break): Use a :emacs-interrupt message + instead of a RPC to swank:simple-break. Suggested by Taylor R + Campbell. + +2006-11-24 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-search-buffer-package): Prettify the package + name if it is written as string or keyword. + +2006-11-23 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-in-expression-p): Use `read' and `eq' to test + the first element of the list. Previuosly, the pattern (foo) + wrongly matched (foobar) because we used (looking-at <symbol>). + + * swank-cmucl.lisp (setf-definitions): Also include defs which + were created with (defun (setf NAME) ...). Previously we only + found definitions created with defsetf or define-setf-expander. + +2006-11-22 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-edit-definition): Don't hide error messages. + +2006-11-21 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (*coding-system*): "Coding systems" are now strings + instead of keywords. + +2006-11-19 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-compile-file): Let the Lisp side choose the + coding system. + (slime-coding): Deleted. + + * swank.lisp (compile-file-for-emacs): Use guess-external-format. + (swank:create-server): no more accepts an :external-format 'enc , + use :coding-system "enc" instead. + + * swank-backend.lisp (find-external-format) + (guess-external-format): New. + (swank-compile-file): The external-format argument is now a + backend specific value returned by find-external-format. + + * swank-cmucl.lisp, swank-sbcl.lisp, swank-clisp, + swank-lispworks.lisp, swank-allegro.lisp, swank-corman.lisp, + swank-ecl.lisp, swank-scl.lisp, swank-abcl.lisp, swank-openmcl: + Update implementations accordingly. + + * swank-source-file-cache.lisp (read-file): Use guess-external-format. + + * swank.lisp (*swank-wire-protocol-version*): Is now initialized + by the loader. + (wire-protocol-version): Removed, because it contained a reference + to swank-loader::*source-directory*. + + * slime.el (slime-set-connection-info): On protocol version + mismatch, ask the user how to proceed. + (slime-protocol-version): New variable. Initialize it at compile + time to detect stale elc files. + + * swank-loader.lisp (load-swank): Set the protocol version. + +2006-11-12 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-make-tramp-file-name): Added (require 'tramp) + since tramp-make-tramp-file-name is not an autoloaded function. + +2006-11-07 Edi Weitz <edi(a)agharta.de> + + * slime.el (slime-fuzzy-completion-time-limit-in-msec): Escaped + left parenthesis in doc string. + +2006-11-05 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-complete-keywords-contextually): Unused + variable, removed. + +2006-11-05 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (sldb-sexp-highlight-mode): Remove bloat. + +2006-11-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Support nested presentations in REPL results, when present.lisp is + loaded. + + * swank.lisp (make-presentations-result): New, factored out from + listener-eval. + (listener-eval): Use it here. + + * present.lisp (make-presentations-result): Override it here. + +2006-11-03 Marco Baringer <mb(a)bese.it> + + * swank.lisp (all-slots-for-inspector): Added declare ignore for + unused argument inspector (openmcl warns about this). Reindented. + +2006-11-01 Attila Lendvai <attila.lendvai(a)gmail.com> + + * slime.el (sldb-sexp-highlight-mode): New custom. + (slime-handle-repl-shortcut): Trigger slime-lookup-shortcut when + the point is anywhere before slime-repl-input-start-mark. IOW, + you can press "," anywhere before the prompt. + (slime-edit-definition): Handle the case when there are only such + entries returned from swank that have errors. + (slime-read-from-minibuffer): Allow overriding of the keymap. + (slime-repl-previous-matching-input): Similar behaviour like + isearch-forward. + (slime-repl-next-matching-input): Ditto. In more details: You can + freely navigate with slime-repl-previous/next-input with M-p and + M-n at any time among the history entries. When M-r is pressed, + which invokes slime-repl-previous-matching-input, the the + minibuffer is activated to read the regexp to search for and the + contents will default to the current repl input. Pressing M-r + again will start searching with the last pattern used no matter + what the content of the minibuffer is. Subsequent invocations of + M-r get the next match, and of course the same applies for M-s, + which is slime-repl-previous-matching-input. + + * swank.lisp (fuzzy-completion-set): Fix on clisp. + (convert-fuzzy-completion-result): Fix symbol fbound and other + annotations. + (slot-value-using-class-for-inspector): New. + (slot-boundp-using-class-for-inspector): New. + (inspect-for-emacs): Use the special slot access methods so that + it's possible to customize the inspecting of complex + slots (e.g. computed-class at + http://common-lisp.net/project/computed-class/). + (all-slots-for-inspector): Converted to generic method. + +2006-11-01 Marco Baringer <mb(a)bese.it> + + * swank.lisp (*swank-wire-protocol-version*): Use a defvar to + declare the existence of tihs variable to the lisp (Reported by: + Jonathon McKitrick <jcm(a)FreeBSD-uk.eu.org>). + +2006-10-30 Marco Baringer <mb(a)bese.it> + + * swank.lisp (*dont-close*): New variable. + (defpackage :swank): Export *dont-close*. + (start-server, create-server): Use *dont-close* as the default + value of the :dont-close parameter. + (connection-info): Send the wire-protocol-version (supplied by the + swank-version.el file) to slime when connecting. + (wire-protocol-version): New function. + + * slime.el (slime-global-variable-name-regexp): New variable. + (slime-global-variable-name-p): Use + slime-global-variable-name-regexp. + ("swank-version"): Load swank-version.el to get the wire protocol + version. + (slime-set-connection-info): Check the wire protocol version. + +2006-10-30 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-global-variable-name-p): Oops... need to handle + very long strings. + +2006-10-29 Attila Lendvai <attila.lendvai(a)gmail.com> + + * slime.el (slime-global-variable-name-p): Use defun* instead of + defun. + +2006-10-29 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-global-variable-name-p): Simplified. + +2006-10-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Add completion for character names. + + * slime.el (slime-completions-for-character): New. + (slime-contextual-completions): Use it here. + + * swank-backend.lisp (character-completion-set): New interface. + + * swank-allegro.lisp (character-completion-set): Implement it. + + * swank.lisp (completions-for-character): New slimefun. + (compound-prefix-match/ci/underscores) + (longest-completion/underscores, tokenize-completion/underscores) + (untokenize-completion/underscores): New functions. + +2006-10-28 Ivan Toshkov <ivan(a)toshkov.org> + + * hyperspec.el: Missing Hyperspec links for ~| and ~~ + +2006-10-27 Ivan Toshkov <ivan(a)toshkov.org> + + * hyperspec.el: Missing Hyperspec links for ~% and ~& + +2006-10-27 Nikodemus Siivola <nikodemus(a)random-state.net> + + * swank-sbcl.lisp (make-weak-key-hash-table): Restore support + for older SBCLs without weak hash-tables. + (make-weak-value-hash-table): Ditto. + +2006-10-26 Utz-Uwe Haus <haus+slime(a)mail.math.uni-magdeburg.de> + + * swank-allegro.lisp (sldb-break-at-start): Implement. + +2006-10-26 Attila Lendvai <attila.lendvai(a)gmail.com> + + * slime.el (slime-setup-command-hooks): Use make-local-hook. + (slime-repl-mode): Ditto. + (slime-fuzzy-choices-buffer): Ditto. + (sldb-mode): Ditto. + (slime-fuzzy-completion-limit): New variable. + (slime-fuzzy-completion-time-limit-in-msec): New variable. + (slime-fuzzy-next): Fix when at the end of the buffer. + (completion-output-symbol-converter): New to handle escaped + symbols for those who need to mess around with symbols like + layered-function-definers::|CONTEXTL::SLOT-VALUE-USING-LAYER|. + When a symbol is escaped then completion is case sensitive. + (completion-output-package-converter): New. + (mimic-key-bindings): New to easily define bindings by first + trying to look up bindings for an operation and only use the + provided default bindings if nothing was found in the source + keymap. Use it to set up fuzzy bindings. (Hint: if you have keys + like previous-line customized, then only load slime after they + have been set, and the fuzzy mode will mimic them.) + (slime-temp-buffer-quit): Always close the opened window, updated + docstring. Also made the fuzzy maps smarter, they now try to look + up keys with 'where-is-internal and map the functions on them. + + * swank-sbcl.lisp + (make-weak-value-hash-table): New for sbcl. + (make-weak-key-hash-table): New for sbcl. + + * swank.lisp (fuzzy-completions and friends): Added :limit and + :time-limit-in-msec keyword params. Used vectors instead of lists + that nearly doubled its speed (at least on sbcl). Also added some + declare optimize and type annotations. + (do-symbols*): New, uses a hash-table to visit only non-seen + symbols. Replaced various uses of do-symbols where it was + appropiate. + +2006-10-26 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-global-variable-name-p): Use a custom 'parser' + instead of string-match to avoid regexp overflow errors on very + long strings. + +2006-10-21 Helmut Eller <heller(a)common-lisp.net> + + * swank-lispworks.lisp (initialize-multiprocessing): Don't init + MP if it is already running. + + * test.sh: Run Emacs in Screen. + +2006-10-20 Helmut Eller <heller(a)common-lisp.net> + + * swank-backend.lisp, swank-cmucl.lisp: + (startup-idle-and-top-level-loops): Deleted. Merged into + initialize-multiprocessing. + +2006-10-20 Attila Lendvai <attila.lendvai(a)gmail.com> + + * slime.el (slime-fuzzy-choices-buffer): Added kill-buffer-hook to + the completion buffer to slime-fuzzy-abort, so we get out from the + completion mode and key maps when the completion buffer is closed. + +2006-10-20 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-target-buffer-fuzzy-completions-map): Fix a bug + I introduced when applying levente's patch. + +2006-10-20 Martin Simmons <martin(a)lispworks.com> + + * swank-backend.lisp (initialize-multiprocessing): New API to + support lisps where initialize-multiprocessing may not return (lispworks). + + * swank.lisp (start-server): initialize-multiprocessing's API has changed. + + * swank-lispworks.lisp (initialize-multiprocessing): Update for new API. + + * swank-cmucl.lisp (initialize-multiprocessing): Update for new API. + + * swank-allegro.lisp (initialize-multiprocessing): Update for new api. + +2006-10-20 Levente M�sz�ros <levente.meszaros(a)gmail.com> + + Added "in-place" fuzzy completion GUI. See + slime-fuzzy-completions-map and + slime-target-buffer-fuzzy-completions-map for details. + + * slime.el (slime-fuzzy-completion-in-place): New variable. + (slime-target-buffer-fuzzy-completions-mode): New keymap for + in-place fuzzy completions. + (slime-fuzzy-target-buffer-completions-mode): New minor mode for + in-place fuzzy completions. + (slime-fuzzy-current-completion-overlay): New overlay for + highlighting currently selected completion. + (slime-fuzzy-completions-map): Added new fuzzy completon keys + (slime-fuzzy-indent-and-complete-symbol): New function. + (slime-fuzzy-complete-symbol): Use new in-place fuzzy completion. + (slime-fuzzy-choices-buffer): Support in-place completion editing. + (slime-fuzzy-fill-completions-buffer): Highlight completions, + don't automatically jump to completion buffer. + (slime-fuzzy-enable-target-buffer-completions-mode, + slime-fuzzy-disable-target-buffer-completions-mode): New modes for + moving in/out of in-place fuzzy completion mode + (slime-fuzzy-next, slime-fuzzy-prev): Don't assume point is in the + completion buffer. + (slime-fuzzy-dehighlight-current-completion, + slime-fuzzy-highlight-current-completion): Manage completion + selection highlighting. + (slime-fuzzy-select-or-update-completions): New function. + (slime-fuzzy-process-event-in-completions-buffer): New function. + (slime-fuzzy-select-and-process-event-in-target-buffer): New function. + (slime-fuzzy-done): Changed to deal with in-place completion. + +2006-10-19 Helmut Eller <heller(a)common-lisp.net> + + * swank-backend.lisp (ignored-xref-function-names): Deleted. + + * swank.lisp (guess-package-from-string): Remove special case for + "#.". parse-package will handle that just fine. + (find-definitions-for-emacs): Don't filter errors out. + (sanitize-xrefs): Moved to swank-sbcl. The backend is supposed to + return sane values. + + * swank-sbcl.lisp: See above. + + * slime.el (slime-find-buffer-package): Simplify. + +2006-10-17 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-accept-process-output): The timeout arg can be + nil. Handle that case. + +2006-10-17 Attila Lendvai <attila.lendvai(a)gmail.com> + + * slime.el (slime-find-buffer-package): Handle #. forms. + + * swank.lisp (guess-package-from-string): Handle #. forms. + (inspect-for-emacs standard-class): Handle non-string + :documentation slot contents. + + * swank-sbcl.lisp (inspect-for-emacs weak-pointer ...): Added + method. + +2006-10-16 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (sldb-activate): Get debug-info from the correct + thread. Fixes bug reported by Dan Weinreb <dlw(a)itasoftware.com>. + (unwind-to-previous-sldb-level): New test. + (slime-init-command): Send a single form. + (slime-insert-presentation): Honor slime-repl-enable-presentations. + Presentations kill SLDB and the inspector in Emacs 20 (besides + being troublesome GC-wise). + + * swank.lisp: Clean up global IO redirection. + (setup-stream-indirection): Turn macro into a + function and delay initialization after user init files are + loaded, so that we do nothing if *globally-redirect-io* is nil. + (*after-init-hook*, run-after-init-hook) + (init-global-stream-redirection): New. + + (parse-symbol-or-lose): Lose loudly and early (instead of failing + silently). + + * swank-loader.lisp: Abort on compile-time or load-time errors. + Don't try to load the source-file if COMPILE-FILE's 3rd return + value is true (it's true even for warnings). + (handle-loadtime-error): New function. + + Run the after-init-hook. + + * swank-cmucl.lisp (inspect-for-emacs): Don't break for + simple-strings. + +2006-10-11 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-presentation-syntax-table): New. + (slime-add-presentation-properties): Install it in a syntax-table + text property, so that #<...> is balanced in a presentation. + (slime-remove-presentation-properties): Remove the text property. + (slime-repl-mode): Respect the syntax text properties of + presentations in REPL buffers. + +2006-10-09 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (completions-for-keyword): Look up the operator names + in the right package. Return nil (rather than signalling an + error) when no valid operator name is present. + +2006-10-08 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank-loader.lisp (lisp-version-string) [allegro]: Distinguish + between 32-bit and 64-bit version on the SPARC architecture. + +2006-10-03 Marco Baringer <mb(a)bese.it> + + Change license statement to say that all files without an explicit + copyright notice are public domain. This change will allow SLIME + to moved out of debian's nonfree tree. + + * README: Update license statement. + +2006-10-02 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-highlight-compiler-notes): New variable. + (slime-compilation-finished): Only highlight notes when + slime-highlight-compiler-notes is non-NIL. + +2006-09-28 Marco Baringer <mb(a)bese.it> + + * swank-loader.lisp (compile-files-if-needed-serially): Don't + ignore compile-time errors but drop into a debugger (it's not a + slime debugger but it's certainly better than ignoring the error). + +2006-09-27 Marco Baringer <mb(a)bese.it> + + * swank.lisp (*globally-redirect-io*): Change default value to T. + +2006-09-25 Juho Snellman <jsnell(a)iki.fi> + + Fix Slime on SBCL 0.9.17. + + * swank-backend.lisp (ignored-xref-function-names): New interface + + * swank.lisp (sanitize-xrefs): Use ignored-xref-function-names + instead of having a #+sbcl special case. + + * swank-sbcl.lisp (ignored-xref-function-names): Implement. + Filter out SB-C::STEP-VALUES, not just SB-C::STEP-FORM, as done by + the old sanitize-xrefs. Don't implement the interface at all if + SBCL is sufficiently new (those symbols don't exist any more, and + there's nothing in their place to be ignored). + +2006-09-21 Marco Baringer <mb(a)bese.it> + + * swank.lisp (find-definitions-for-emacs): Don't return locations + whose CAR is :error. + (xref): Process whatever is returned by the various xref functions + with the new sanitize-xrefs functions. + (sanitize-xrefs): Clean up the list of xrefs to remove duplicates. + Patch by Dan Weinreb <dlw(a)itasoftware.com> + + * slime.el (slime-goto-first-note-after-compilation): New + variable. This controls the behaviour of (next|prev)-note + immediatly after a slime-compile-and-load-file. + (slime-compilation-just-finished): New variable. + (slime-compilation-finished): Update slime-compilation-finished. + (slime-next-note, slime-previous-note): Respect + slime-compilation-just-finished. + (slime-autodoc-use-multiline-p): Specify the type. + (slime-repl-grab-old-input): Typo in docstring. + (slime-cheat-sheet): Deal with multiple-bindings + (slime-cheat-sheet-table): Update as per #lisp's suggestions. + +2006-09-20 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-cheat-sheet): New function. + (slime-cheat-sheet-table): New variable which specifies what the + cheat sheet should list. + (slime-read-package-name): Set require to T in the call to + completing read, it doesn't make any sense to switch to an + inexistent package. + + * doc/slime.texi: Added "Tips and Tricks" chapter (need a better + name for this). + + * swank-sbcl.lisp (fallback-source-location): Use abort-request + instead of error. + (locate-compiler-note): Say, in the error message, what data + caused the error. + +2006-09-20 Juho Snellman <jsnell(a)iki.fi> + + * swank-sbcl.lisp (call-with-debugger-hook): use INVOKE-STEPPER + instead of calling the stepper hook manually + +2006-09-19 Juho Snellman <jsnell(a)iki.fi> + + * swank-sbcl.lisp (call-with-debugger-hook): make the stepper + also work with a threaded SBCL, by binding a handler for + sb-ext:stepper-condition instead of relying on the one that SBCL + establishes on the toplevel + +2006-09-19 Juho Snellman <jsnell(a)iki.fi> + + Extend the stepper protocol to work nicely with the SBCL stepper. + + If sldb is invoked on a condition that's sldb-stepper-condition-p, + the sldb functions sldb-step, sldb-next and sldb-out will invoke + the matching backend functions for stepping into the stepped form, + to the next form, or out of the current function. Otherwise the + functions will behave like sldb-step used to (call active-stepping and + select the continue restart). + + * swank-backend.lisp (sldb-stepper-condition-p, sldb-step-into, + sldb-step-next, sldb-step-out): New interface functions + + * swank-sbcl.lisp (activate-stepper, condition-extras, + sldb-stepper-condition-p, sldb-step-into, sldb-step-next, + sldb-step-out): Implemented (conditional on CVS SBCL) + (call-with-debugger-hook): bind sb-ext:*stepper-hook* to + a function that binds *stack-top-hint* and invokes the debugger + (conditional on CVS SBCL) + + * swank.lisp (define-stepper-function): new macro for defining + stepper-related functions, since they all follow the same form + (sldb-step): redefine with define-stepper-function + (sldb-next, sldb-out): new functions + (*sldb-stepping-p*): typo in docstring + + * slime.el (sldb-next, sldb-out): New commands + (sldb-mode-map): bind sldb-next to "x" and sldb-out to "o" + +2006-09-18 Dan Weinreb <dlw(a)itasoftware.com> + + For those cases where SLIME can't complete a user request (like + loading an asdf system without asdf or describing an inexistent + symbol) instead of signaling an error SWANK should politely inform + the user and return normally. + + * swank.lisp (eval-for-emacs): Handle request-abort conditions. + (decode-keyword-arg, get-repl-result, parse-symbol-or-lose): Use + abort-request instead of error. + + * swank-backend.lisp (request-abort): New condition. + (abort-request): Convenience function for signaling request-abort + conditions. + (operate-on-system): Use abort-request instead of error + (:swank-backend): Export the symbols abort-request and + request-abort. + + * slime.el (slime-rex): Update docstring. + (slime-eval, slime-eval-async): Added new REASON parameter sent + along with :abort message. + +2006-09-14 Douglas Crosher <dcrosher(a)common-lisp.net> + + * swank-scl (arglist, function-arglist, spawn): update for the SCL. + +2006-09-13 Brandon Bergren <bdragon(a)mailsnare.net> + + * slime.el (slime-filename-translations): Fix docstring + +2006-09-13 Bob Halley <halley(a)play-bow.us> + + * swank.lisp (format-iso8601-time): Properly handle non integer + time zones. + +2006-09-13 Taylor R Campbell <campbell(a)mumble.net> + + * slime.el (slime-init-output-buffer): Initial directory and + package stacks should be empty. + (slime-repl-push-package): Push the current package, as opposed to + the new package, and set the new package to whatever the user + specified. + (slime-repl-pop-package): Set the current package to the top of + the package stack, unless it's empty. + +2006-09-13 Daniel Koning <dkoning(a)seas.smu.edu> + + * slime.el (slime-repl-disconnect): New repl shortcut. + +2006-09-13 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-open-inspector): Added a slime-part-number + property to the topline so that you can slime-inspector-copy-down + the object being inspected. There are some cases where we have an + object in the inspector and we'd like to dump it to the repl but + we can't get at it through other means (like in back-traces). + (slime-insert-xrefs): Specify which file the item is in (when that + information is available). + + * swank.lisp (format-arglist-for-echo-area): Instead of using + let+first+rest to destructure a form use destructuring-bind. + (lookup-presented-object): Added (declare (special + *inspectee-parts*)) to silence openmcl's compiler. + (inspect-object): Generate, and send to emacs, an ID for the + object being inspected. + +2006-09-01 Nikodemus Siivola <nikodemus(a)random-state.net> + + * slime.el (slime-repl-matching-input-regexp): Use the portion + between slime-repl-input-mark and point for history search, not + the entire input. Patch by Ivan Shvedunov. + + * swank-sbcl.lisp: Declaim SB-C:INSERT-STEP-CONDITIONS 0 for to + hide Swank while stepping and avoid endless mutex-acquisition + loops. + +2006-08-27 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (input-available-p, process-available-input): Use + READ-CHAR-NO-HANG instead of LISTEN because LISTEN suddenly + returns false in SBCL 0.9.?? even if we are called from a + fd-handler and the OPEN-STREAM-P returns true. + +2006-08-26 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-repl-return-behaviour): Fix the defcustom type, + so Emacs 21.3 does not signal an error when creating a + customization buffer containing this variable. + +2006-08-25 Kai Kaminski <kai.kaminski(a)gmx.de> + + * swank.lisp (lookup-presented-object): Fix for OpenMCL 1.0 + [ppc32], which requires that the :NO-ERROR clause is last in + HANDLER-CASE. + +2006-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-ensure-presentation-overlay): Provide a + help-echo for presentations, showing the mouse bindings. + (slime-presentation-around-click): New function. + (slime-copy-or-inspect-presentation-at-mouse) + (slime-inspect-presentation-at-mouse) + (slime-copy-presentation-at-mouse) + (slime-describe-presentation-at-mouse) + (slime-pretty-print-presentation-at-mouse): New commands. + (slime-copy-presentation-at-point): Removed (misnomer). + (slime-presentation-map): Bind mouse-2 to + slime-copy-or-inspect-presentation-at-mouse, so the right thing is + done in REPL buffers and in Inspector and Debugger buffers. + (slime-menu-choices-for-presentation): Use the new commands here + instead of inline lambdas. + (sldb-inspect-in-frame): Use slime-read-object here, so if point + is in a presentation in the debugger buffer, inspect it + immediately just like slime-inspect does. + (slime-inspect-presented-object): Removed. + (slime-inspect): Don't expect that "swank:init-inspector" is + already part of the form. Accept an optional arg "no-reset". + (slime-read-object): Don't add "swank:init-inspector" to the read + form; slime-inspect now adds it. + +2006-08-21 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Make the values of local variables in debugger frames and values + of parts in the inspector accessible as presentations. In + particular, this allows to copy #<unreadable> values to the REPL + for further investigation. It also provides a context menu for + the values, offering to inspect, pretty-print, and describe them. + + Note that the presentations are only valid as long as the + corresponding Inspector or Debugger buffer is open. + + * swank.lisp (lookup-presented-object): Handle presentation ids + (:frame-var frame index), (:inspected-part part-index). + (init-inspector): New optional argument, reset. + + * slime.el (slime-inspector-insert-ispec): Mark up all values of + inspected parts as presentations. + (sldb-insert-locals): Mark up the values of local variables as + presentations. + (slime-remove-presentation-properties): Fix for read-only buffers. + (slime-copy-presentation-at-point): Make it work when the current + buffer is not the REPL buffer. + (slime-menu-choices-for-presentation): Describe into a separate + buffer, not the REPL. New menu item, pretty-print. + (slime-presentation-expression): Handle presentation ids that are + not numbers. + (slime-inspect-presented-object): Don't reset the inspector if + already in the inspector buffer. + +2006-08-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (*nil-surrogate*): New. + (save-presented-object, lookup-presented-object): Distinguish + between a saved NIL and a garbage-collected object that was + replaced by NIL in the weak hash table. + (compute-enriched-decoded-arglist with-open-file): Add an IGNORE + declaration. + +2006-08-19 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-parse-extended-operator-name/apply): New. + (slime-extended-operator-name-parser-alist): Add it to the alist. + + * swank.lisp (compute-enriched-decoded-arglist): Add method for + handling APPLY. + +2006-08-14 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-accept-process-output): Use brute-force to + detect whether accept-process-output can be called with a float as + timeout arg. + + * swank-openmcl.lisp: Fix some breakage caused by the new + defimplementation. + +2006-08-11 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (close-connection, swank-error): Include backtraces + in our own errors. + (simple-serve-requests): Don't try to enter the + debugger if the connection is closed. + + * slime.el (disconnect): Test disconnecting. + + * swank-cmucl.lisp (startup-idle-and-top-level-loops): Initialize + MP only once. + +2006-08-10 Helmut Eller <heller(a)common-lisp.net> + + * swank-allegro.lisp (fspec-definition-locations): Improve + handling of (:internal ... n) like fspecs. + + * slime.el (slime-restart-inferior-lisp-aux): Remove the + interactive spec. + + * swank-backend.lisp (definterface): Drop that incredibly + unportable CLOS stuff. Use plists and plain functions instead. + Update backends accordingly. + +2006-08-09 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-find-filename-translators): CL:MACHINE-INSTANCE + can return nil. Silently accept that case for now. + + * swank.lisp (test-print-arglist): Print a message instead of + signalling an error. This should avoid startup problems, in + particular with CormanLisp. + (setup-stream-indirection): Disable it for now. We should fix it, + if there is a need for this functionality or just remove it. + + * swank-backend.lisp (definterface): Bring the old implementation + based on NO-APPLICABLE-METHOD back. It avoids lots of redefintion + warnings (but it creates more "noise" in backtraces). + + * swank-*.lisp (inspect-for-emacs): Don't use defimplementation + for real generics. + +2006-07-28 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-thread-quit): Call swank:quit-thread-browser. + Reported by Taylor R Campbell. + +2006-07-28 Willem Broekema <metawilm(a)gmail.com> + + * swank-allegro.lisp: Profiling functions on Allegro (except for + profile-package). + +2006-07-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Add support for destructuring macro arglists in arglist display, + form completion, and keyword completion; in particular for + with-open-file. + + * swank.lisp (find-valid-operator-name): New, factored out from + arglist-for-echo-area. + (arglist-for-echo-area): Use it here. + (print-arglist): New, factored out from decoded-arglist-to-string. + Handle recursive arglist structures that arise in destructuring + macro arglists. + (decode-required-arg, encode-required-arg): New, handle + destructuring patterns. + (decode-keyword-arg, encode-keyword-arg, decode-optional-arg) + (encode-optional-arg, decode-arglist, encode-arglist): Use them + here to handle destructuring patterns. + (print-decoded-arglist-as-template): Change interface, handle + destructuring patterns. + (decoded-arglist-to-template-string): Use it here. + (enrich-decoded-arglist-with-keywords): New, factored out from + enrich-decoded-arglist-with-extra-keywords. + (enrich-decoded-arglist-with-extra-keywords): Use it here. + (compute-enriched-decoded-arglist): New generic function, factored + out from arglist-for-insertion, form-completion. Add specialized + method for with-open-file. + (arglist-for-insertion, form-completion): Use it here. + (arglist-ref): New. + (completions-for-keyword): Change interface, handle destructuring + macro arglists. + + * slime.el (slime-enclosing-operator-names): For nesting levels + without operator, record nil. + (slime-completions-for-keyword): New argument arg-indices. + (slime-contextual-completions): Pass all enclosing operators and + arg-indices to slime-completions-for-keyword. + +2006-07-16 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-edit-definition): Invoke the + slime-edit-definition-fall-back-function also in the case where + find-definitions-for-emacs returns an error message. + (slime-edit-definition-fallback-function): Fix typo (find-tag + rather than find-tags). + +2006-07-15 Juho Snellman <jsnell(a)iki.fi> + + * swank-sbcl.lisp (preferred-communication-style): Remove use of + linux_no_threads_p alien variable (the value has been hardcoded to + false for about a year), so that we can also remove it from from SBCL + in the future. + (*definition-types*): defcondition -> define-condition, + to make slime-show-definitions display condition FOO as + (DEFINE-CONDITION FOO) instead of (SWANK-BACKEND::DEFCONDITION FOO). + +2006-07-15 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-shared-lisp-mode-hook): New function, factored + out from slime-lisp-mode-hook. + (slime-lisp-mode-hook): Use it here. + (slime-scheme-mode-hook): New function, use + slime-shared-lisp-mode-hook. + (slime-setup): If scheme-mode is one of the slime-lisp-modes, + install our hook. + +2006-07-13 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (keywords-of-operator): New support function for + writing user-defined `extra-keywords' methods. + +2006-07-11 Helmut Eller <heller(a)common-lisp.net> + + * swank-allegro.lisp (make-weak-key-hash-table): Use ACL's weak + hashtables. + + * swank.asd: Set *source-directory* to the asdf component dir. + +2006-07-01 Lu�s Oliveira <loliveira(a)common-lisp.net> + + * swank-sbcl.lisp (locate-compiler-note): Change first branch to + handle the changes introduced by the previous patch to + swank-compile-string. + +2006-06-26 Helmut Eller <heller(a)common-lisp.net> + + * swank-sbcl.lisp (find-definitions): Remove backward + compatibility code. + +2006-06-26 Lu�s Oliveira <loliveira(a)common-lisp.net> + + * swank-sbcl.lisp (tmpnam, temp-file-name): New functions. + (swank-compile-string): Create temporary file with the string and + compile-file it instead of compiling an anonymous lambda, as + before, in order to better handle eval-when forms. + +2006-06-25 Helmut Eller <heller(a)common-lisp.net> + + * swank-source-path-parser.lisp (suppress-sharp-dot): Return a + unique symbol to avoid multiple entries for nil at toplevel in the + source-map. + + * slime.el (test compile-defun): Add a test for #. reader macro at + toplevel. + (slime-run-one-test): New command. + (sldb-activate): Recreate the sldb buffer if it doesn't + exist. (Can happen if someone kills the buffer manually.) + (slime-wait-condition): Add a dummy to slime-stack-eval-tags while + waiting so that the SLDB enters a recursive edit. + +2006-06-18 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-echo-arglist): Simplify, just use slime-autodoc. + + * swank.lisp (arglist): Distinguish between provided actual args + and required formal args using the new slot provided-args. + (form-completion): Likewise. + (decoded-arglist-to-string): Use it here to display the argument + list (make-instance 'CLASS-NAME ...) rather + than (make-instance (quote CLASS-NAME) ...). + + * swank.lisp (extra-keywords change-class): Don't drop the first + argument. + + * slime.el (slime-parse-extended-operator-name): Don't move + point; fixes infinite loop. + +2006-06-17 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-parse-extended-operator-name/cerror): Handle + cerror and change-class with :make-instance. + (slime-extended-operator-name-parser-alist): Handle change-class. + (slime-parse-extended-operator-name) + (slime-enclosing-operator-names): Fix the case when point is + within the operator. + + * swank.lisp (operator-designator-to-form): Handle cerror and + change-class with :make-instance. + +2006-06-16 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (operator-designator-to-form): Handle :cerror. + (extra-keywords cerror): Make it work. + + * slime.el (slime-parse-extended-operator-name) + (slime-parse-extended-operator-name/make-instance) + (slime-parse-extended-operator-name/defmethod): New functions, + factored out from slime-enclosing-operator-names. + (slime-parse-extended-operator-name/cerror): New function. + (slime-extended-operator-name-parser-alist): New variable. + (slime-enclosing-operator-names): Use them here. + +2006-06-14 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-goto-definition): If all definitions of a name + have the same location, go there directly rather than presenting + an xref buffer. + +2006-06-11 Douglas Crosher <dcrosher(a)common-lisp.net> + + * swank-scl (ext:stream-write-chars): update for SCL 1.3. + +2006-06-09 Alan Ruttenberg <alanr-l(a)mumble.net> + + * swank-abcl: Update to cvs version of abcl and warnings errors + when compiling in a buffer will now be properly caught by slime vs + current behavior of always saying 0 errors 0 warnings and printing + them in the repl instead + +2006-05-31 Nathan Bird <nathan(a)acceleration.net> + + * swank.lisp (*sldb-quit-restart*): New variable. + (throw-to-toplevel): Use the restart named by *sldb-quit-restart* + as opposed to hard coding abort-request. + +2006-05-30 Tobias Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-get-temp-buffer-create): New keyword REUSEP + which indicates whether an already-existing buffer named like the + buffer to be created should be reused, i.e. not killed, then + freshly created. Update docstring accordingly. + (slime-with-output-to-temp-buffer): Make &optional arg MODE an + &key keyword arg. Add REUSEP keyword. + (slime-macroexpansion-minor-mode-map): Make remapped `undo' update + highlighted edits in the macroexpansion buffer. + (slime-eval-macroexpand-in-place): Update highlighted edits when + macroexpanding in-place. + (slime-eval-macroexpand): Reuse macroexpansion buffer if it exists + already to preserve `undo' functionality. + +2006-05-30 Tobias Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-use-autodoc-mode): Fix typo in docstring. + (slime-use-highlight-edits-mode): New variable, analogous to + SLIME-USE-AUTODOC-MODE. + (slime-setup, slime-lisp-mode-hook): Make above variable + work. Also, activates the HIGHLIGHT-EDITS-MODE in proper way (thus + avoiding the nasty "Toggling ... off; better pass an explicit + argument." message.) + + * slime.el: Fix typo in comment about communication protocol. + +2006-05-27 Alan Ruttenberg <alanr-l(a)mumble.net> + * swank-abcl: slot-boundp-using-class slot-value-using-class so you + can inspect instances + +2006-05-26 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime.el (slime-eval-macroexpand-inplace): Fix out-of-range + error on in-place macroexpand when point is placed at a closing + parenthesis. In this case the sexp closed by that paren is + expanded. + Also make expanding of expressions work that are quoted like, for + instance, "'(FOO BAR)" if point is placed at the opening paren. + +2006-05-24 Brian Downing <bdowning(a)lavos.net> + + * swank.lisp (recursively-compute-most-completions & friends): + Micro-optimize the fuzzy completion engine, improving performace + by a factor of about 4 on SBCL. However, it will only work on + simple-strings now, and CHAR= is burned in instead of being an + option. I don't think this is too much of a limitation. At this + point rendering the results on the emacs side takes much longer + than finding them for long result lists. + +2006-05-24 Alan Ruttenberg <alanr-l(a)mumble.net> + * swank-abcl: Add some more mop functions to you can inspect classes, + generic functions, methods, slots. + +2006-05-16 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-repl-return-behaviour): New variable which + controls slime-repl-return's heaviour. + (slime-repl-return): Respect slime-repl-return-behaviour. + +2006-05-14 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-macroexpansion-minor-mode-map): Rebind 'undo' to + set buffer-read-only temporarily to t. + (slime-repl-return): Only send repl input if point is past a + complete form. + +2006-05-12 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (update-indentation-information): Fix for problem + with Allegro CL 8.0: If I type M-x slime-update-indentation, + Allegro CL starts growing until it hits a STORAGE-CONDITION or + even segfaults. + +2006-05-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank-allegro.lisp (fspec-definition-locations): Handle + :top-level-form entries that appear in backtraces. + +2006-04-20 Marco Baringer <mb(a)bese.it> + + * swank-openmcl.lisp (toggle-trace): Implemented. Currently only + provides 'best effort' support, :labels and :flet are ignored, + :defmethod and :call are treated like a normal trace of the + operator. + +2006-04-20 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (*use-dedicated-output-stream*): Make it nil by + default to avoid race conditions. + +2006-04-19 Christophe Rhodes <csr21(a)cam.ac.uk> + + * doc/Makefile (contributors.texi): use texinfo macros for + accented characters. + + * ChangeLog: canonize Gabor Melis' spelling, otherwise he appears + twice in the "Hackers of the good Hack table" + + * doc/slime.texi (nyorsko): delete + (EDITION): make it say 2.0 + +2006-04-19 Christophe Rhodes <csr21(a)cam.ac.uk> + + * swank.lisp (decoded-arglist-to-string): if the keyword and the + variable are different, print the keyword name with escapes. + (encode-keyword-arg): get the keyword and the arg-name the same + way round as in lambda lists. + (appliable-methods-keywords): use + swank-mop:compute-applicable-methods-using-classes and + compute-applicable-methods in the AMOP-friendly way, to get EQL + specializers right. + (class-from-class-name-form, extra-keywords/slots): new. + (extra-keywords/make-instance): use new functions. Also get + keywords from SHARED-INITIALIZE (after Dan Barlow) and + ALLOCATE-INSTANCE. + (extra-keywords/change-class): new. + (extra-keywords (eql 'change-class)): new. Won't work at present, + just as the CERROR case doesn't work. + +2006-04-19 Christophe Rhodes <csr21(a)cam.ac.uk> + + * swank-sbcl.lisp (preferred-communication-style): Make it nil + under win32, for now. + + * doc/slime.texi: document nil *communication-style* + +2006-04-18 Espen Wiborg <espenhw(a)grumblesmurf.org> + + * swank-corman.lisp: Define a class file-stream to let swank.lisp + load. + +2005-04-17 Andras Simon <andras(a)renyi.hu> + + * swank-abcl.lisp: (accept-connection): New argument: timeout. + +2006-04-14 Gerd Flaig <gefla(a)pond.sub.org> + + * slime.el (slime-autodoc): Fix reference to unbound variable. + +2006-04-13 Martin Simmons <martin(a)lispworks.com> + + * swank-loader.lisp (load-site-init-file, swank-source-files): Fix + pathname construction to take all unspecified components from the + directory pathname, in particular the drive letter on Windows. + +2006-04-13 Helmut Eller <helmut(a)common-lisp.net> + + * slime.el (slime-find-filename-translators): Use assoc-if instead + of assoc-default for XEmacs compatibility. + (slime-show-note-counts): Don't show the highlighting bit as it + spills of the screen. + (slime-highlight-notes): Use with-temp-message. + (with-temp-message): Define it for XEmacs. + (slime-beginning-of-symbol): Use eq instead of char-equal as + char-equal signals an error at the beginning of a buffer. + +2006-04-13 Douglas Crosher <dcrosher(a)common-lisp.net> + + * swank-scl (make-socket-io-stream): set the stream to ignore + character conversion errors, and to substitute the character #\?. + Without this the communication channel is prone to lockup when a + conversion error occurs. + + * swank-scl (inspect-for-emacs function): correct the index into the + closure environment; it was reading off the end of the closure + environment and picking up a corrupting value. + + * swank-scl (mailbox): rework the mailbox implementation to better + handle interruption. Use a polling loop rather than condition + variables because interrupting a condition variable wait leaves the + thread with the condition variable lock held and leads to a deadlock + error. + +2006-04-12 Robert Macomber <slime(a)rojoma.com> + + * swank-backend.lisp (make-recursive-lock): New interface + function. + (call-with-recursive-lock-held): New interface function. + + * swank-grey.lisp (class slime-output-stream): Added recursive + locking to class and generic functions specialized on it. + (clss slime-input-stream): Added recursive locking to class and + generic functions specialized on it. + + * swank-sbcl.lisp (make-recursive-lock): Implement the new interface. + (call-with-recursive-lock): Implement the new interface. + +2006-04-01 Matthew D. Swank <akopa(a)charter.net> + + * slime.el (slime-fontify-string): Use set-text-properties, not + propertize, for Emacs 20 compatibility. + +2006-03-30 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-init-command): Don't translate filenames since + the new scheme doesn't work without a connection. + (slime-to-lisp-filename,slime-from-lisp-filename): Remove some + redundancy. + (slime-macroexpansion-minor-mode): Make it Emacs 20 compatible. + +2006-03-29 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-repl-mode): Enable autodoc-mode if + slime-use-autodoc-mode is true. + +2006-03-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (multiple-value-or): New macro. + + * slime.el (slime-recently-visited-buffer): Ignore internal + buffers (starting with a space), to avoid selecting the + *slime-fontify* buffer. Reported by Andreas Fuchs. + + * slime.el (slime-enclosing-operator-names): Handle forms similar + to make-instance (make-condition, error, etc.), to get extra + keywords based on the condition class. + + * swank.lisp (operator-designator-to-form): Handle forms similar + to make-instance (make-condition, error, etc.) + (extra-keywords/make-instance): New function. + (extra-keywords): Specialize on operators make-condition, error, + signal, warn, cerror. Use multiple-value-or. + +2006-03-27 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-make-tramp-file-name): If emcas' tramp has + tramp-multi-methods then pass the method parameter to + tramp-make-tramp-file-name, otherwise don't. + (slime-create-filename-translator): Use + slime-make-tramp-file-name. + +2006-03-27 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * hyperspec.el (common-lisp-hyperspec-strip-cl-package): New + function. + (common-lisp-hyperspec): Don't get confused by a cl: or + common-lisp: package prefix. + + * slime.el (slime-hyperspec-lookup): Don't get confused by a cl: + or common-lisp: package prefix. + +2006-03-26 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-enclosing-operator-names): Fix for situation + when point is at end of buffer, as it happens often in the REPL. + +2006-03-25 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (arglist-for-echo-area): New keyword arg, + print-lines. + (decoded-arglist-to-string): New function, implement argument + highlighting also for &optional and &rest/&body arguments. + (arglist-to-string): Use decoded-arglist-to-string. + (arglist): New slots aux-args, known-junk, unknown-junk. + (nreversef): New macro. + (decode-arglist, encode-arglist): Refine to handle more structure + in argument lists, including implementation-defined stuff like + &parse-body. + (format-arglist-for-echo-area): New keyword arg, print-lines. + Simplify the code as there is no need to fall back to the unparsed + arglist any more. + + * slime.el (slime-fontify-string): Fix for arguments spanning + multiple lines. + (slime-autodoc-message-dimensions): New. + (slime-autodoc-thing-at-point): Use it here to either ask for a + one-line or a nicely formatted multi-line arglist. + (slime-enclosing-operator-names): Handle linebreaks. + +2006-03-24 Mikel Bancroft <mutandiz(a)yahoo.com> + + * swank-allegro.lisp (set-default-directory): Fix for pathnames + without a trailing slash. + +2006-03-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-background-activities-enabled-p): Allow + "background activities" in sldb-mode. + (slime-autodoc-message-ok-p): Allow autodoc in sldb-mode. + (sldb-mode-syntax-table): New variable. + (sldb-mode): Enable autodoc-mode when slime-use-autodoc-mode is + true. Use sldb-mode-syntax-table to make #<...> balance like + parentheses. This enables autodoc-mode to match #<unreadable> + actual arguments in the backtraces with formal arguments of the + function. + (slime-beginning-of-symbol, slime-end-of-symbol): Handle + es::|caped| symbols. + (slime-enclosing-operator-names): Use syntax table to check + whether we are at the beginning of a balanced expression. + +2006-03-23 Christophe Rhodes <csr21(a)cam.ac.uk> + + * swank.lisp (ed-in-emacs): Allow conses as function names. + Ensure that there is a connection to emacs before sending the + :ed message. + + * slime.el (slime-edit-definition): read names, not symbols. + (slime-ed): handle conses whose car is not a string as function + names. + +2006-03-23 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-qualify-cl-symbol-name): Strip leading colon + from package names for qualifying symbols. + (slime-call-defun): New command. + (slime-keys): Bind it to C-c C-y. + (slime-easy-menu): Show it in the menu. + + * slime.el (slime-autodoc-use-multiline-p): New defcustom. + (slime-autodoc-message): Use it here. Fix bug that autodoc + messages exceeding one line could not be overwritten by later + autodoc messages. + (slime-autodoc-pre-command-refresh-echo-area): Use message + rather than slime-background-message. + + * swank.lisp (casify): Removed. + (casify-char, tokenize-symbol-thoroughly): New functions. + (parse-symbol): Use tokenize-symbol-thoroughly, so as to handle + |escaped symbols|. This fixes arglist display for operators with + strange symbol names. + +2006-03-23 Douglas Crosher <dcrosher(a)common-lisp.net> + + * swank-backend (accept-connection): add a 'timeout argument to + this function. + + * swank-backend (set-stream-timeout): new implementation specific + function. Used to set the timeout for stream operations, which + can help make the network connection establishment more robust. + + * swank (setup-server): ignore errors from the function 'serve to + allow another connection to be made. + + * swank (serve-connection): ensure the listener socket is closed + when 'dont-close is false, even if the connection attempt fails. + + * swank (accept-authenticated-connection): ensure the new + connection is closed if the connection establishment fails. Set a + short stream timeout to prevent denial of survice. + + * swank (open-dedicated-output-stream): ensure the listener socket + is closed, even if unable to open the dedicated stream. Implement + a timeout while waiting for a connection for the dedicate stream + to prevent denial of service. + + * swank (create-connection): ensure the new connection is closed + if not successful. + +2006-03-22 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (arglist-for-echo-area): Fix when arg-indices are + not given. + + * slime.el (slime-ed): Handle (FILENAME :charpos CHARPOS). + + * swank.lisp (inspect-for-emacs): Specialize on FILE-STREAM and + STREAM-ERROR, offering to visit the file at the current stream + position as an inspector action. Useful for dealing with reader + errors. + +2006-03-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-autodoc-pre-command-refresh-echo-area): + Show the last autodoc message again (movement commands clear it); + technique to avoid flickering, taken from eldoc. + (slime-autodoc-mode): Install it as a pre-command-hook. + (slime-autodoc-last-message): New variable. + (slime-autodoc-message): New function. + (slime-autodoc): Use them here. + (slime-autodoc-message-ok-p): OK to overwrite an autodoc message. + + * slime.el (slime-handle-indentation-update): Also update + scheme-indent-function if slime-lisp-modes contains scheme-mode. + +2006-03-19 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Highlight the formal argument corresponding to the actual + argument around point in the echo-area arg-list display. + Works most impressively when slime-autodoc-mode is enabled + and when one has to deal with extremely long argument lists. + + * slime.el (slime-space): First insert the space, then obtain + information. + (slime-fontify-string): Also handle argument highlights. + (slime-enclosing-operator-names): As a secondary value, return a + list of the indices of the arguments to the nested operator. + (slime-contextual-completions): Use changed interface of + slime-enclosing-operator-names. + (slime-function-called-at-point): Removed. + (slime-function-called-at-point/line): Removed. + (slime-autodoc-thing-at-point): New. + (slime-autodoc): Re-implement with slime-enclosing-operator-names + instead of slime-function-called-at-point. + (slime-echo-arglist): Pass the argument indices to + arglist-for-echo-area. + (slime-autodoc-message-ok-p): Autodoc is also OK in REPL buffers. + + * swank.lisp (arglist-for-echo-area): New keyword argument + arg-indices. + (arglist-to-string): New keyword argument highlight. + (format-arglist-for-echo-area): Likewise. + +2006-03-18 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-goto-location-buffer): Avoid calling the + expensive function find-file-noselect when we are already in the + right buffer. + + * swank.lisp (arglist-for-echo-area): Add keyword argument + print-right-margin. + (arglist-to-string, format-arglist-for-echo-area): Likewise. + * slime.el (slime-autodoc): Use it here to make use of the whole + width of the echo area for arglist display. + +2006-03-16 G�bor Melis <mega(a)hotpop.com> + + * swank-allegro.lisp (inspect-for-emacs): Fix typo. + +2006-03-16 Gary King <gwking(a)metabang.com> + + * swank-loader.lisp (lisp-version-string): Modified swank-loader + so that Allegro's alisp and mlisp programs get different + locations. Otherwise mlisp complains about alisp's files. + +2006-03-16 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-to-lisp-filename): Call expand-file-name before + passing the filename to the to-lisp function. + +2006-03-14 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-system-history): New variable. + (slime-read-system-name): Use a separate history list for ASDF + system names. + (slime-note-counts-message): New variable. + (slime-show-note-counts): Store the note counts message for later use. + (slime-highlight-notes, slime-list-compiler-notes): Show a + progress message, keeping note counts visible. + (slime-find-buffer-package): Handle IN-PACKAGE forms that appear + in SWIG/Allegro CL wrappers. + + * swank-allegro.lisp (compile-from-temp-file): Suppress Allegro's + redefinition warnings; they are pointless when we are compiling + via a temporary file. + (profile-report): Implement. + +2006-03-06 Nathan Bird <nathan(a)acceleration.net> + + * slime.el (slime-create-filename-translator): use the tramp + methods for dissecting and building filenames. + +2006-03-04 Wojciech Kaczmarek <wojtekk(a)kofeina.net> + + * slime.el (slime-filename-translations): Typo in example. + (slime-create-filename-translator): Typo in generated lambdas. + +2006-03-03 Marco Baringer <mb(a)bese.it> + + Allow per-host (per machine-instance actually) filename + translation functions. + + * slime.el (slime-translate-to-lisp-filename-function): removed. + (slime-translate-from-lisp-filename-function): removed. + (slime-filename-translations): New variable. + (slime-to-lisp-filename): Rewrote to search through available + transalations. + (slime-from-lisp-filename): idem. + (slime-create-filename-translator): New function. + (slime-add-filename-translation): New function. + +2006-02-27 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-eval-macroexpand-inplace): Indent the inserted + macroexpansion. + +2006-02-27 Marco Baringer <mb(a)bese.it> + + Provide functions for performing macroexpansion inplace, use these + functions in the *SLIME macroexpansion* buffer. + + * slime.el (slime-macroexpansion-minor-mode): Attempt to map + -inplace functions to the same keys as their regular contureparts + in slime-mode-map. + (slime-eval-macroexpand-inplace): New function. + (slime-macroexpand-1-inplace): New function. + (slime-macroexpand-all-inplace): New function. + * doc/slime.texi: Document new macroexpansion mode. + +2006-02-26 Douglas Crosher <dcrosher(a)common-lisp.net> + * swank-scl.lisp: (ext:stream-read-chars): Correct the updating of + the buffer index. Fixes slime input stream problems. + +2006-02-25 Helmut Eller <heller(a)common-lisp.net> + + * swank-loader.lisp (default-fasl-directory): Previously we return + only the directory-namestring which breaks SCL, because it loses + the host and device components. Return the complete pathname + instead. Patch by Douglas Crosher. + + * slime.el (slime-lisp-host): New variable. Replace all references + to "127.0.0.1" with the variable. + +2006-02-25 Douglas Crosher <dcrosher(a)common-lisp.net> + + * swank-backend.lisp (operate-on-system): symbol case fix for + SCL's lowercase mode. + + * swak.lisp (setup-stream-indirection) + (globally-redirect-io-to-connection) + (revert-global-io-redirection): symbol case fixes. + + * swank-scl.lisp: (inspect-for-emacs): Fixes for the inspect + standard-objects, and inspect array. Plus misc symbol case fixes. + +2006-02-22 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-repl-send-input): Don't include the final + newline in the slime-repl-input-face overlay, thus avoid showing the + "Evaluation aborted" message in boldface. Don't set non-existent + "rear-nonsticky" overlay property; overlay stickiness is + controlled by make-overlay arguments. + +2006-02-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Use argument list information to complete keywords contextually. + Example: (find 1 '(1 2 3) :s <M-TAB> --completes--> :start + rather than suggesting all ever-interned keywords starting with ":s". + + * slime.el (slime-complete-keywords-contextually): New + customizable variable. + (slime-enclosing-operator-names): New optional argument + max-levels. + (slime-completions-for-keyword): New. + (slime-contextual-completions): New. + (slime-expand-abbreviations-and-complete): Use it instead of + slime-completions. + + * swank.lisp (operator-designator-to-form): New, factored out from + arglist-for-echo-area. + (arglist-for-echo-area): Use it here. + (completions-for-keyword): New. + (find-matching-symbols-in-list): New. + +2006-02-19 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-expand-abbreviations-and-complete): Scroll the + completions buffer if the TAB key is pressed another time, like + Emacs minibuffer completion does. + +2006-02-18 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-macroexpansion-minor-mode): New minor mode for + macroexpansion buffer. Exactly like slime-temp-buffer-mode but + with slime-macroexpand-again bound to "g". + (*slime-eval-macroexpand-expression*): New variable. introduced + for slime-macroexpand-again, used by slime-eval-macroexpand as + well. + (slime-eval-macroexpand): Added optional string argument which + defaults to (slime-sexp-at-point-or-error). + (slime-macroexpand-again): New function, redoes the last + macroexpansion. + (slime-sexp-at-point-or-error): New function. Like + slime-sexp-at-point but signals an error when slime-sexp-at-point + would return nil. + * swank-openmcl.lisp (swank-mop:compute-applicable-methods-using-classes): + Implement. + +2006-02-16 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * sbcl-pprint-patch.lisp: New file, adds the annotations feature + to the SBCL pretty printer. This is needed for sending + presentations through pretty-printing streams. + * present.lisp [sbcl]: Load it here. + (slime-stream-p, write-annotation) [sbcl]: Handle pretty-streams. + +2006-02-10 Helmut Eller <heller(a)common-lisp.net> + + * swank-allegro.lisp, swank-lispworks.lisp (inspect-for-emacs): + Use the backend specific method to inspect standard-objects + because {slot-boundp,slot-value}-using-class don't conform to the + MOP spec in LW and ACL. + + * swank.lisp (macro-indentation): Don't count '&optional as + argument. + + * swank-loader.lisp (default-fasl-directory): Include the SLIME + version. + (slime-version-string): New. + +2006-02-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Show enriched arglists for DEFMETHOD in the echo area when the + user types SPC after the generic function name. + + * swank.lisp (arglist-to-template-string): Unused, removed. + (extra-keywords): Indicate which part of the actual arglist was + used to determine the extra keywords. For MAKE-INSTANCE, don't + signal an error if the class does not exist. + (enrich-decoded-arglist-with-extra-keywords): Indicate which part + of the actual arglist was used to determine the extra keywords, + and whether any extra keywords were added. + (form-completion): Generalize to handle display of enriched formal + arglists. + (read-incomplete-form-from-string): New, factored out from + complete-form. Handle end-of-file. + (complete-form): Use it here. + (format-arglist-for-echo-area): Use form-completion, so as to + show enriched formal arglists for MAKE-INSTANCE and DEFMETHOD + calls. + (arglist-for-echo-area): Handle MAKE-INSTANCE and DEFMETHOD + calls. + + * slime.el (slime-enclosing-operator-names): Represent + MAKE-INSTANCE calls by (:make-instance "CLASS-NAME"), handle + DEFMETHOD too. + +2006-02-05 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-complete-form): Indent the inserted template. + +2006-02-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-fontify-string): New. + (slime-echo-arglist, slime-arglist, slime-autodoc): Use it here to + fontify echo-area arglists. + +2006-02-02 Marco Baringer <mb(a)bese.it> + + * swank-openmcl.lisp: Added imports for slot-boundp-using-class, + slot-value-using-class and finalize-inheritance. + +2006-02-01 Alan Ruttenberg <alanr-l(a)mumble.net> + + * swank-abcl.lisp: define with-compilation-hooks (= funcall for now), so that you can do slime-oos + +2006-01-30 Ian Eslick <eslick(a)csail.mit.edu> + + Show slot values for metaclasses that override the default storage + locations for objects slots (i.e. where the default slot-boundp + returns nil) in the inspector. + + * swank.lisp (inspect-for-emacs standard-object): Use + slot-value-using-class and slot-boundp-using-class. + + * swank-backend.lisp: Add slot-value-using-class and + slot-boundp-using-class to the swank-mop package. + +2006-01-26 Lu�s Oliveira <loliveira(a)common-lisp.net> + + * slime.el (slime-enclosing-operator-names): detect make-instance + forms and collect the class-name argument if it exists and is a + quoted symbol. + + * swank.lisp (arglist-for-echo-area): handle pairs of of the form + ("make-instance" . "<class-name>") by passing them to + format-initargs-and-initforms-for-echo-area. + (class-initargs-and-iniforms): New function. + (format-initargs-and-initforms-for-echo-area): New function. + +2006-01-20 M�sz�ros Levente <melevy(a)freemail.hu> + + * swank-sbcl.lisp (restart-frame): Provide an implementation even + if it doesn't quite do what it's supposed to do. + +2006-01-19 Helmut Eller <heller(a)common-lisp.net> + + Return to the previous loading strategy: load everything when + swank-loader is loaded. It's just to convenient to give that up. + To customize the fasl directories, the new variable + swank-loader:*fasl-directory* can be set before loading + swank-loader. + + * swank-loader.lisp (*fasl-directory*, *source-directory*): New + variables. + (load-swank): Call it during loading. + +2006-01-14 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-compile-defun): If point was at the opening + paren we wrongly used the preceding toplevel form. Fix it. + Reported by Chisheng Huang and Liam M. Healy. + + * swank.lisp (spawn-threads-for-connection): Fix a race condition: + Don't accept input before all threads are ready. + + Make the fasl directory customizable: load-swank must now be + called explicitly so that we can supply the fasl dir as argument. + + * swank-loader.lisp (load-swank): New entry point. + +2006-01-14 Andreas Fuchs <asf(a)boinkor.net> + + * slime.el (slime-selector ?r): Call slime instead of slime-start + to pick up the usual defaults. + +2005-12-31 Harald Hanche-Olsen <hanche(a)math.ntnu.no> + + * slime.el (slime-open-stream-to-lisp): Inherit the + process-coding-system from the current connection. + +2005-12-27 Alan Ruttenberg <alanr-l(a)mumble.net> + + * swank-abcl. (backtrace-as-list-ignoring-swank-calls): remove the + swank calls from the backtrace to make it easier to use. + (frame-locals): Fix a typo that caused entry into the debugger if + you tried to look at frame locals. Now you don't error out, but + you still don't see frame locals because I don't know how to get + them :( + +2005-12-27 Helmut Eller <heller(a)common-lisp.net> + + Keep a history of protocol events for better bug reports. + + * swank.lisp (log-event): Record the event in the history buffer. + (*event-history*): Buffer for events. + (dump-event-history): New function. + (close-connection): Escape non-ascii strings and include the event + history in the error message. + +2005-12-22 Helmut Eller <heller(a)common-lisp.net> + + Make highlighting of modified text a minor mode. Also use + after-change-functions instead of rebinding all self-inserting + keys. + + * slime.el (slime-highlight-edits-mode): New minor mode. + (slime-self-insert-command): Deleted. + (slime-before-compile-functions): New hook to decouple edit + highlighting from compilation. + (slime-highlight-edits-face): Renamed from slime-display-edit-face. + +2005-12-20 Marco Baringer <mb(a)bese.it> + + When inspecting classes, methods and generic functions show all + the slots in the case that what we're inspecting is a subclass of + the standard class and has extra user defined slots. + + * swank.lisp (all-slots-for-inspector): New function. + (inspect-for-emacs): Use all-slots-for-inspector. + +2005-12-19 Peter Seibel <peter(a)gigamonkeys.com> + + * slime.el (slime-self-insert-command): Got rid of message about + setting up face and skipping edit-hilights when in a comment. + +2005-12-18 Nikodemus Siivola <nikodemus(a)random-state.net> + + * slime.el (slime-mode-hook): Bind simple characters to + slime-self-insert-command only if there was no previous local + binding, and the major mode is _not_ slime-repl-mode. This + restores keybindings of slime-xref-mode and prevents us from + stomping on user bindings. The hilighting also makes no sense in + the REPL. + +2005-12-16 Nikodemus Siivola <nikodemus(a)random-state.net> + + * slime.el (slime-selector-method: ?r): If no connection offer to + start Slime. + + * swank.lisp (to-string): Handle errors from printing objects. + Among other things makes the inspector more robust in the face of + objects with unbound slots and print-methods that fail to cope. + +2005-12-16 William Bland <doctorbill.news(a)gmail.com> + + Added hilighting of tetx which has been edited but not yet + compilied. + + * slime.el (slime-display-edit-hilights): New variable. + (slime-display-edit-face): New face. + (slime-compile-file, slime-compile-defun, slime-compile-region): + Remove edits overlay. + (slime-remove-edits): New function. + (slime-self-insert-command): New function. + (slime-mode-hook): Rebind simple characters to + slime-self-insert-command. + +2005-12-07 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank-allegro.lisp (find-definition-in-file) + (find-fspec-location, fspec-definition-locations): Allegro CL + properly records all definitions made by arbitrary macros whose + names start with "def". Use excl::find-source-file and + scm:find-definition-in-definition-group (rather than + scm:find-definition-in-file) to find them. + + * slime.el (slime-load-file): Change the default to be the buffer + file name with extension. This is more convenient for files like + .asd files that do not have the default source file extension. + (slime-save-some-lisp-buffers, slime-update-modeline-package): + Handle all files with major mode in slime-lisp-modes, not just + lisp-mode. + +2005-12-06 Juho Snellman <jsnell(a)iki.fi> + + * swank-sbcl.lisp (function-source-location, + safe-function-source-location): Oops, define these functions also + for the >0.9.6 case. Fixes broken sldb-show-source on SBCL 0.9.7. + +2005-12-05 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-find-coding-system): Use check-coding-system + only if it's actually fbound. + +2005-11-22 Marco Monteiro <masmxx(a)gmail.com> + + * slime.el (slime-connect): Use slime-net-coding system if the + optional arg coding-system was not supplied. + +2005-11-22 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-compile-file): Call 'check-parens before + compiling. + (slime-compile-file): Call 'check-parens before compiling. + (slime-find-coding-system): Return nil if the coding system + isn'tvalid instead of singalling an error. + (slime-repl-history-file-coding-system): Use + slime-find-coding-system to find the default. + + * swank-cmucl.lisp (accept-connection): Remove fd-handlers if the + encoding isn't iso-latin-1. + +2005-11-21 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-start): Don't set slime-net-coding-system .. + (slime-read-port-and-connect): .. read it from the inferior lisp args. + (slime-connect): Take the coding-system as third argument. + (slime-repl-history-file-coding-system): New user option. + (slime-repl-safe-save-merged-history): New function. Use it in + hooks so that bad coding systems don't stop us from exiting. + (slime-repl-save-history): Include the coding-system which was + used to save the buffer. + (repl-shoctut change-package): Add alias ,in and ,in-package. + (slime-eval-macroexpand): Error out early if there's no sexp at + point. + (slime-compiler-macroexpand): New command. + (slime-inspector-pprint): New command. + + * swank-cmucl.lisp (inspect-for-emacs): Add support for + funcallable instances. + + * swank.lisp (pprint-inspector-part, swank-compiler-macroexpand): New. + + * swank-backend.lisp (compiler-macroexpand) + (compiler-macroexpand-1): New functions. + +2005-11-14 Douglas Crosher <dcrosher(a)common-lisp.net> + + * swank-scl.lisp (accept-connection): handle the :buffering argument. + +2005-11-13 Andras Simon <andras(a)renyi.hu> + + * swank-abcl.lisp: (accept-connection): New argument: buffering. + +2005-11-13 Andras Simon <andras(a)renyi.hu> + + * swank-abcl.lisp: Steal auto-flush stuff from swank-sbcl.lisp + +2005-11-11 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (*dedicated-output-stream-buffering*): New variable + to customize the buffering scheme. For single-threaded Lisps we + disable buffering because lazy programmers forget to call + finish-output. + (open-dedicated-output-stream): Use it. + + * swank-backend.lisp, swank-allegro.lisp, swank-lispworks.lisp, + swank-openmcl.lisp, swank-cmucl.lisp, swank-sbcl.lisp, + swank-clisp.lisp, swank-abcl.lisp, swank-corman.lisp, + swank-ecl.lisp (accept-connection): New argument: buffering. + + * slime.el (slime-repl-save-history): When the history exceeds + slime-repl-history-size remove the old not the new entries. + Some renaming: + slime-repl-read-history -> slime-repl-load-history, + slime-repl-read-history-internal -> slime-repl-read-history. + (slime-eval-macroexpand): Call font-lock-fontify-buffer + explicitly, because with certain Emacs versions the buffer doesn't + get fontified immediately. + +2005-11-07 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-eval-macroexpand): Use lisp-mode (and + font-lock-mode) when dispaying the expansion. Suggested by Jan + Rychter. + + * swank-source-path-parser.lisp (make-source-recording-readtable): + Suppress the #. reader-macro. + +2005-11-06 Juho Snellman <jsnell(a)iki.fi> + + * swank-sbcl.lisp (find-definitions, make-source-location-specification + make-definition-source-location, source-hint-snippet): As of + SBCL 0.9.6.25 SB-INTROSPECT has better support for finding + source locations. Use as much of it in swank-sbcl as possible. + (Original version left reader-conditionalized for older SBCLs). + +2005-11-04 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (connection-info): Docfix. + + * slime.el (slime-set-connection-info): Generate a new connection + name only if the implementation-name and the inferior-lisp-name + are different. + +2005-10-31 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-start, slime-lookup-lisp-implementation) + (slime-set-connection-info): Add a :name property for the + implementation and use it to derive the connection-name. + (slime-lisp-implementation-name): Renamed from + slime-lisp-implementation-type-name. + + * swank.lisp (simple-serve-requests): Add an extra abort restart. + (connection-info): Rename :type-name to :name. + +2005-10-30 Andras Simon <andras(a)renyi.hu> + + * swank-abcl.lisp (inspect-for-emacs): Track mop changes in ABCL. + +2005-10-30 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-eval): Ensure that the connection is open before + waiting for input. + + * swank.lisp (simple-serve-requests): Close the connection at the + end. + +2005-10-23 Harald Hanche-Olsen <hanche(a)math.ntnu.no> + + * slime.el (slime-init-keymaps): Use vectors when defining keys, + because e.g. (define-key (string ?\C-c) ...) doesn't work in the + emacs-unicode-2 branch. + +2005-10-23 Stefan Kamphausen <skampi(a)gmx.net> + + * slime.el (slime-repl-history-size, slime-repl-history-file): Use + defcustom to declare the variables. + +2005-10-23 G�bor Melis <mega(a)hotpop.com> + + * swank-backend.lisp (install-debugger-globally): new interface + function + + * swank.lisp (install-debugger): call install-debugger-globally + + * swank-sbcl.lisp (install-debugger-globally): set + sb-ext:*invoke-debugger-hook* too + +2005-10-23 Helmut Eller <heller(a)common-lisp.net> + + * swank-sbcl.lisp (make-stream-interactive): Spawn a thread to + flush interactive streams in reasonably short intervals. + Remove the old backward-compatible threading implementation. + + * swank.lisp (package-string-for-prompt): Respect *print-case*. + +2005-10-21 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-start-swank-server): Avoid comint-send-input + here as it seems to trigger a bug in ansi-color-for-commit-mode. + +2005-10-18 Douglas Crosher <dcrosher(a)common-lisp.net> + + * swank.lisp (canonical-package-nickname): always return the + package name as a STRING if found. This restores the printing of + package names as strings. + +2005-10-17 Marco Baringer <mb(a)bese.it> + + * swank.lisp (eval-in-emacs): Instead of taking a string and + attempting to parse it emacs side the function now takes a form + and converts it to a string internally. This should allow users of + the function to not have to worry about quoting issues and emacs' + different printed represenation for, among other things, + characters. + (process-form-for-emacs): New function. Converts a list into a + string for passing to emacs. + + * slime.el (slime-eval-for-lisp): New API. This function now takes + a single string, representing the form to evaluate, and uses + emacs' read function to convert it into a form before eval'ing it. + (slime-dispatch-event): The :eval event now passes a single + string (instead of a string and something looking kind of like a + form). + +2005-10-15 Douglas Crosher <dcrosher(a)common-lisp.net> + + * swank-scl.lisp: Support for Scieneer Common Lisp. + + * swank-backend.lisp (*gray-stream-symbols*) Scieneer Common Lisp + implements stream-line-length. + + * swank-loader.lisp: Support for Scieneer Common Lisp: + (*sysdep-pathnames*) use swank-scl. + (*impl ementation-features*) add :scl. + (*os-features*) add :hpux. + (*architecture-features*) add :amd64, :i686, :i486, :sparc64, :sparc, + :hppa64, and :hppa. + + * swank.lisp: (*canonical-package-nicknames*) use lowercase + symbols to name the packages. This supports CL implementations + with lowercase default symbol names, such as Scieneer Common Lisp, + while still being compatible with ANSI-CL. + +2005-10-11 Stefan Kamphausen <skampi(a)gmx.net> + + * slime.el: Persistent REPL history. The history from REPL + buffers is now saved to the file ~/.slime-history.eld. The file + is read on startup and saved when a REPL buffer gets killed or + when Emacs exits. There are also commands to save or read the + history file. + (slime-repl-save-merged-history, slime-repl-merge-histories) + (slime-repl-read-history, slime-repl-save-history): New functions. + (slime-repl-history-file, slime-repl-history-size): New vars. + (slime-repl-mode): Add hooks to load and save the history. + +2005-10-11 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-read-interactive-args): Split the string + inferior-lisp-program to get the values for :program and + :program-args. Also let slime-lisp-implementations take + precedence if non-nil. + (slime-lisp-implementations): Renamed from + slime-registered-lisp-implementations. + + * swank.lisp (force-user-output): There seems to be a bug in + Allegro's two-way-streams. As a workaround we use force-output for + the user-io stream. (finish-output *debug-io*) still triggers the + bug. + +2005-10-10 Svein Ove Aas <svein.ove(a)aas.no> + + * swank-allegro.lisp (find-external-format): Translate :utf-8-unix + to :utf8, which Allegro 7.0 understands. + +2005-10-09 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime, slime-start): Introduce a separate function for + the non-interactive case. `slime-start' takes lots of keyword + arguments and `slime' is reserved for interactive use. + (slime-read-interactive-args): New function. + (slime-maybe-start-lisp, slime-inferior-lisp) + (slime-start-swank-server): Pass all arguments needed to start + the subprocess as a property list. Also store this list in a + buffer-local var in the inferior-lisp buffer, so that we can + cleanly restart the process. + (slime-registered-lisp-implementations): Change the format and + document it. M-- M-x slime can now be used select a registered + implementation. + (slime-symbolic-lisp-name): Deleted. And updated all the functions + which passed it along. + (slime-set-connection-info): Use the new format. + (slime-output-buffer): Don't re-initialize buffer-local variables + if the buffer already exists. This saves the history. From Juho + Snellman. + + * swank-cmucl.lisp (sis/in): Use finish-output instead of + force-output. + + * swank.lisp (connection-info): Include the initial package and + a more self-descriptive format. + +2005-10-01 Juho Snellman <jsnell(a)iki.fi> + + * swank-backend (*gray-stream-symbols*): Add :STREAM-LINE-LENGTH + to *GRAY-STREAM-SYMBOLS* on implementations that support this + extension to gray streams. Reported by Matthew D Swank. + +2005-09-29 Luke Gorrie <luke(a)synap.se> + + * swank-scheme48: Removed due to excessive whining. + +2005-09-28 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-multiprocessing): Deleted. No longer needed. + (slime-init-command): Updated accordingly. + (slime-current-package): Add a special case for Scheme. + (slime-simple-completions, slime-apropos): Quote the package, + because in can be a plain symbol in Scheme. + (slime-inspector-reinspect): Use a proper defslimefun. + + * swank.lisp (inspector-reinspect): New function. + (start-server): Call initialize-multiprocessing before starting + the server and startup-idle-and-top-level-loops afterwards. + Calling startup-idle-and-top-level-loops here shouldn't be a + problem because start-server is only invoked at startup via stdin. + + * swank-scheme48/source-location.scm: New file. For M-. + * swank-scheme48/module.scm (list-all-package): New function. + * swank-scheme48/interfaces.scm (module-control-interface): Export it. + * swank-scheme48/inspector.scm: Add methods for records and hashtables. + (swank:arglist-for-echo-area): Implement it. Only works for + functions with enough debug-data (ie. only user-defined functions). + * swank-scheme48/completion.scm: New file. + (swank:simple-completions, swank:apropos-list-for-emacs): Implemented. + * swank-scheme48/load.scm, swank-scheme48/defrectypeX.scm: Renamed + the file from defrectype*.scm + * swank-scheme48/packages.scm (swank-general-rpc): Don't use + posix-process because it doesn't work on Windows, and we don't need + it for a mulithreaded server. + +2005-09-22 Helmut Eller <heller(a)common-lisp.net> + + * swank-backend.lisp (*gray-stream-symbols*): Collect the needed + symbols here, so that we don't need to mention them in every + backend. + (import-from). New function. + + * swank-sbcl.lisp, swank-allegro.lisp, swank-lispworks.lisp, + swank-openmcl.lisp, swank-ecl.lisp: Use *gray-stream-symbols* when + importing the needed symbols. + + * swank-gray.lisp (stream-fresh-line): Define a method, so that + Allegro passes our tests. + +2005-09-21 Aleksandar Bakic <a_bakic(a)yahoo.com> + + * swank.lisp (accept-authenticated-connection): Minor fix. Ensure + that the decoded message is a string before calling string= on it. + +2005-09-21 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-setup-command-hooks): Make + after-change-functions a buffer-local variable; it's by default + global in XEmacs. + + * swank.lisp (throw-to-toplevel): Invoke the `abort-restart' + request instead of throwing to the `slime-toplevel' catch tag. + (handle-request): Rename the restart from abort to abort-request. + (call-with-connection): Remove the slime-toplevel catch tag + because with-connection is used in far to many places which aren't + at "toplevel". + + * present.lisp (presentation-start, presentation-end): Use + finish-output instead of force-output. + + * swank-gray.lisp, swank-cmucl.lisp: Improve stream efficiency by + buffering more output. stream-force-output simply does nothing, if + the output buffer was flushed less than 200 millisecons before. + stream-finish-output can still be used to really flush the buffer. + (slime-output-stream): New slot last-flush-time. + (stream-finish-output): New function. Do what stream-force-output + did previously. + (stream-force-output): Buffer more output. + + * slime.el (slime-process-available-input): Oops, don't start a + timer for every event. + (slime-write-string): Renamed from slime-output-string. + (slime-dispatch-event): Rename :read-output to :write-string. + (slime-io-speed-test): New command. + (slime-open-stream-to-lisp): Fix parens. The coding system should + also be set if presentations are disabled. + + * swank.lisp (make-output-function): Rename :read-output to + :write-string. + (eval-for-emacs, interactive-eval, eval-region): Use finish-output + not force-output. + + * swank-sbcl.lisp, swank-openmcl.lisp, swank-allegro.lisp, + swank-lispworks: Import `stream-finish-output'. + + * swank-scheme48/io.scm (empty-swank-output-buffer): Rename + :read-output to :write-string. + + * swank-scheme48/load.scm (slime48-start): Fix '() vs. #f bug. + +2005-09-19 Luke Gorrie <luke(a)synap.se> + + * nregex.lisp: Released into the public domain by Lawrence E. Freil. + +2005-09-19 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime48): New command. + +2005-09-19 Taylor Campbell <campbell(a)mumble.net> + + * swank-scheme48/: New backend. + +2005-09-18 Wolfgang Jenkner <wjenkner(a)inode.at> + + * bridge.el: cl is required at macro expansion time (because of + `block'). Reported by Matthew D Swank. + +2005-09-18 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp: Move presentation menu protocol here from present.lisp. + +2005-09-15 Alan Ruttenberg <alanr-l(a)mumble.net> + * slime.el (slime-repl-return) don't copy presentation to input if + already in input area. + +2005-09-15 Helmut Eller <heller(a)common-lisp.net> + + * swank-clisp.lisp (compute-backtrace): Include only "function + frames" in the backtrace. I hope that makes some sense. + (sldb-backtrace, function-frame-p): New functions. + (*sldb-backtrace*, call-with-debugging-environment, nth-frame): + Compute and remember the backtrace when entering the debugger. + (arglist): If the function has a function-lambda-expression, fetch + the arglist from there. + (find-encoding): Use strings instead of 'charset:foo symbols to + avoid compile time problems if the charset is not available. + Suggested by Vaucher Laurent. + + * swank.lisp (eval-in-emacs): Fix a race condition which occurred + with sigio. + (*echo-area-prefix*): New variable. + + * slime.el (slime-process-available-input): Simplify it a bit and + make it easier to debug read errors. + (slime-net-close): Don't kill the buffer if the new optional arg + `debug' is true. + (slime-run-when-idle): Accept arguments for the function. + (slime-init-connection-state): Close over the proc variable. It + was lost when the async evaluation returned. + (slime-output-buffer, slime-connection-output-buffer): Make + slime-output-buffer faster by keeping the buffer in a connection + variable. + (slime-restart-inferior-lisp-aux, slime-quit-lisp): Disable the + process filter to avoid errors in XEmacs. + +2005-09-14 Alan Ruttenberg <alanr-l(a)mumble.net> + + * slime.el (slime-menu-choices-for-presentation), (slime-presentation-menu) + Fix loss after refactoring. xemacs can't handle lambda forms in + the menu spec given to x-popup-menu, only symbols, so save the + actions in a hash table keyed by a gensym, give x-popup-menu the + gensym and then call the gensym. Haven't checked that it actually + works in xemacs because my xemacs is hosed in os x Tiger. Could + someone let me know... + + * swank.lisp (inspect-factor-more-action) + rename (inspect-show-more-action) Prompt before reading how many + more. Would be nicer to prompt in the minibuffer... + +2005-09-14 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-presentation-expression): Remove handling of + cons presentation-ids. + +2005-09-13 Alan Ruttenberg <alanr-l(a)mumble.net> + + * slime.el (defcustom slime-ed-use-dedicated-frame ... vs defvar + + (defcustom slime-when-complete-filename-expand: Use + comint-replace-by-expanded-filename instead of + comint-dynamic-complete-as-filename to complete file names + + * swank.lisp (run-repl-eval-hooks .. finally (return vs no return + + inspector-call-nth-action Allow second value :replace for inspector actions + + (defvar *slime-inspect-contents-limit* default nil. How many elements of + a hash table or array to show by default. If table has more than + this then offer actions to view more. Set to nil for no limit. Probably should + set default to reasonable value - I like 200. + + (inspect-for-emacs ((ht hash-table) inspector)) - banner line is hash table object. + Respect *slime-inspect-contents-limit* + + (defmethod inspect-for-emacs ((array array) inspector) + Respect *slime-inspect-contents-limit* + + * swank-openmcl.lisp inspector for closures shows closed-over + values. To be fixed: inspector-princ needs to be loaded earlier + since swank package not available when compiling + +2005-09-13 Helmut Eller <heller(a)common-lisp.net> + + * present.lisp (menu-choices-for-presentation-id): Use + lookup-presented-object secondary return value instead of + *not-present*. + (execute-menu-choice-for-presentation-id, presenting-object-1): + Remove references to *can-print-presentation*. + + * slime.el (slime-current-output-id): Remove this ugly klugde. + (slime-repl-insert-result): New function. Handle the presentations + and other special cases cleaner. + (slime-repl-insert-prompt): Use it. The `result' arg is now a + structured list; update callers accordingly. + (slime-repl-return): Make the prefix arg work again. + (package-updating): The result of swank::listener-eval changed a + bit. Update the test. + + Remove some unnecessary uses of `defun*' and reindent it to 80 + columns. + + * swank.lisp: Simplify the object <-> presentation-id mapping. + (save-presented-object): Remove the optional `id' arg. + (lookup-presented-object): Id should be a fixnum not some cons + with fuzzy/non-documented meaning. Use the secondary return value + to test for absence of the id. Update callers accordingly. + (*not-present*): Deleted. + + Remove the repl result special cases, let the general presentation + machinery handle it. + (*last-repl-result-id*, add-repl-result, *current-id*) + (clear-last-repl-result): Deleted. + (listener-eval): Don't *current-id* to tag result values. + + (*can-print-presentation*): Deleted. Nobody quite knows whether + it's still needed so let just try without it. Updated referrers + accordingly. + + (eval-region, run-repl-eval-hooks): Move the eval hook stuff to + a separate function. + + * swank-loader.lisp (lisp-version-string)[cmu]: Replace spaces + with underscores. + +2005-09-12 NIIMI Satoshi <sa2c(a)sa2c.net> + + * swank.lisp, slime.el, swank-clisp.lisp, swank-sbcl.lisp: add + EUC-JP as coding system. This patch eliminates the requirement of + Mule-UCS to use Japanese characters. (Nice for pre-22 Emacs + users.) + +2005-09-10 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-enable-evaluate-in-emacs): Resurrected. + (slime-dispatch-event): Respect slime-enable-evaluate-in-emacs for + messages :eval-no-wait and :eval. + +2005-09-09 Alan Ruttenberg <alanr-l(a)mumble.net> + * slime.el (slime-choose-overlay-region). Don't try to overlay a + note if location is nil. + +2005-09-08 Alan Ruttenberg <alanr-l(a)mumble.net> + + * bridge.el Fix bug in bridge filter where a bridge message which + straddled a packet would be mishandled. Sometimes this would + result in spurious bridge message text being inserted with the + presentation and the presentation not being sensitive. In other + cases there would be an actual error. Introduce bridge-leftovers + to save the last, unfinished bit for the next call, and prepend it + before processing a chuunk. Also, fix the parentheses so that the + unwind protect cleanup forms are actually in the cleanup section. + In openmcl, where apparently communication with slime is done in + 2k chunks, you can trigger the bug with something like this: + (swank::presenting-object 'foo t + (dotimes (i 2040) (write-char #\:))) + + * swank-openmcl.lisp (handle-compiler-warning). Don't create a + location if the condition doesn't have a filename. If it does, + make sure you pass a string rather than a pathname object + otherwise you get a net-read error + +2005-09-07 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * present.lisp (menu-choices-for-presentation): The + Inspect/Describe/Copy items are now provided from the Emacs side. + Implement all pathname menu items without having Emacs evaluate a + form. Fix for Lisps where ".lisp" is parsed as :name ".lisp". + + * slime.el (slime-menu-choices-for-presentation): New function, + return a menu with Inspect/Describe/Copy plus the items that come + from the menu protocol. + (slime-presentation-menu): Security improvement for the + presentation menu protocol: Don't eval arbitrary forms coming from + the Lisp. Minor cleanup: Use x-popup-menu in the normal Emacs way, + associating a command with each menu item. + +2005-09-05 Helmut Eller <heller(a)common-lisp.net> + + * swank-cmucl.lisp (background-message): New function. Forward the + call to the front end. + (pre-gc-hook, post-gc-hook): Use it. + (swank-sym, sending-safe-p): Deleted. + + * swank.lisp (y-or-n-p-in-emacs): Simplify arglist. + (evaluate-in-emacs, dispatch-event, send-to-socket-io): Remove + evaluate-in-emacs stuff. + (to-string): Undo last change. to-string is not to supposed to + ignore errors. Bind *print-readably* instead. + (background-message): New function. + (symbol-external-p): Simplify it a little. + + * slime.el (slime-setup-command-hooks): Add after-change-functions + only if presentations are enabled. + (slime-dispatch-event, slime-enable-evaluate-in-emacs) + (evaluate-in-emacs): Remove evaluate-in-emacs stuff. It was not + used and redundant. + (slime-save-some-lisp-buffers): Renamed from + save-some-lisp-buffers. + (slime-choose-overlay-region): Ignore :source-form locations. + (slime-choose-overlay-for-sexp): Ignore errors when stepping over + forms. + (slime-search-method-location, slime-goto-location-position): Move + all this regexpery to its own function. + (slime-recenter-if-needed, slime-repl-return): Factor some + duplicated code into its own function. + (slime-presentation-bounds, slime-presentation-around-point) + (slime-presentation-around-or-before-point): Minor cleanups. + +2005-09-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-ensure-presentation-overlay): New. + (slime-add-presentation-properties): Don't add face, mouse-face, + keymap text properties. Call slime-ensure-presentation-overlay to + implement them via overlays. + (slime-remove-presentation-properties): Don't remove these text + properties. Delete the right overlay. + (slime-after-change-function): Add overlays for presentations if + necessary. + (slime-copy-presentation-at-point): Don't add face text property. + (slime-repl-grab-old-output): Likewise. + +2005-08-31 Marco Baringer <mb(a)bese.it> + + * swank.lisp (to-string): Handle errors during printing of objects. + +2005-08-30 Alan Ruttenberg <alanr-l(a)mumble.net> + * slime.el (slime-mark-presentation-start/end-handler) modify + regexp to recognize negative presentation ids to make + presenting-object work with bridge mode. + +2005-08-30 Luke Gorrie <luke(a)synap.se> + + * present.lisp: Added public domain dedication (OK'd by Alanr and + Matthias on the list). + +2005-08-29 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank-lispworks.lisp (env-internals:confirm-p): Use new function + y-or-n-p-in-emacs rather than eval-in-emacs. + + * swank-cmucl.lisp (eval-in-emacs): Removed. + (send-to-emacs): New. + (pre-gc-hook, post-gc-hook): Use new protocol message + :background-message rather than eval-in-emacs. + + * swank.lisp (dispatch-event, send-to-socket-io): Handle new + messages :y-or-n-p, :background-message. + (y-or-n-p-in-emacs): New function. + + * slime.el (slime-dispatch-event): Handle new messages :y-or-n-p, + :background-message. + (slime-y-or-n-p): New. + +2005-08-29 Alan Ruttenberg <alanr-l(a)mumble.net> + + * slime.el (sldb-insert-condition) - Add tooltip for long + condition string which otherwise falls off the right of the screen + * swank.lisp (list-threads) - thread name might be a symbol - pass + the symbol name when that happens + +2005-08-29 Juho Snellman <jsnell(a)iki.fi> + + * swank-sbcl.lisp (make-weak-key-hash-table): Remove the + implementation; SBCL doesn't actually support weak hash-tables. + +2005-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-repl-kill-input): New command. + (slime-repl-mode-map): Bind it to C-c C-u, like in comint. + (slime-repl-easy-menu): Include it in the REPL menu. + (slime-repl-mode-hook): Show the SLIME menu in the REPL too. + + * swank-backend.lisp (make-weak-key-hash-table) + (make-weak-value-hash-table): New interfaces. + * swank-cmucl.lisp (make-weak-key-hash-table): Implement it. + * swank-sbcl.lisp (make-weak-key-hash-table): Implement it. + * swank-openmcl.lisp (make-weak-key-hash-table) + (make-weak-value-hash-table): Implement it. + + * swank.lisp (*object-to-presentation-id*) + (*presentation-id-to-object*): Use new functions + make-weak-key-hash-table, make-weak-value-hash-table. + + * slime.el (slime-enable-evaluate-in-emacs): New variable. + (evaluate-in-emacs): Security improvement: If + slime-enable-evaluate-in-emacs is nil (the default), don't + evaluate forms sent by the Lisp. + + * swank.lisp (send-to-socket-io): Handle :evaluate-in-emacs. + +2005-08-27 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-presentation-menu): When an object is no longer + recorded, remove text properties from the presentation. + +2005-08-15 Alan Ruttenberg <alanr-l(a)mumble.net> + + * swank-openmcl.lisp (condition-source-position) + ccl::compiler-warning-stream-position is sometimes nil, so placate + this function by making it (or .. 0). Wrong but I don't have + enough time now to figure out what the right thing is. + + +2005-08-24 Marco Baringer <mb(a)bese.it> + + * swank.lisp (fuzzy-find-matching-symbols): When completing the + string "package:" present a list of all the external symbols in + package (completing "package::" lists internal symbols as well). + (inspect-for-emacs standard-class): List all the slots in the + class (as per standard-object). The previous method of hard coding + the slots in the inspector's code made inspecting custom + meta-classes useless. + +2005-08-24 Christophe Rhodes <csr21(a)cam.ac.uk> + + * swank-sbcl.lisp (method-definitions): present qualifiers (if + any). + +2005-08-23 Taylor R. Campbell <campbell(a)bloodandcoffee.net> + + * slime.el (slime-goto-location-position): Added a second regexp + for the :function-name case which matches "(def... ((function-name + ..." (with N opening parens preceding the function name). This is + to allow scheme48 style function names and definitions. + +2005-08-22 Wolfgang Jenkner <wjenkner(a)inode.at> + + * swank-clisp.lisp (fspec-pathname): Cope with CVS CLISP's + (documentation symbol 'sys::file) returning a list. Return either + a list of start and end line positions or nil as second value. + (fspec-location): Use it. Also, if we have to guess the name of a + source file make sure that it actually exists. + + (with-blocked-signals, call-without-interrupts): Don't add + :linux to *features* since this changes the return value of + unique-directory-name in swank-loader.lisp. + Comment out with-blocked-signals. + + Update some comments at the top of the file. + State the licence in the same terms as slime.el does. + +2005-08-21 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * present.lisp (menu-choices-for-presentation-id): Check against + the gensym in *not-present* instead of :non-present. + +2005-08-20 Christophe Rhodes <csr21(a)cam.ac.uk> + + * swank-sbcl.lisp (preferred-communication-style): guard against + non-Linux non-linkage-table platforms (and assume that they won't + have dodgy threads) with #+linux. + +2005-08-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Enable nested presentations. + + * slime.el (slime-presentation): Remove slots start-p, stop-p. + (slime-add-presentation-properties): Use a new text property + layout. Also add an overlay to enable nested highlighting. + (slime-remove-presentation-properties): New. + (slime-presentation-whole-p): Changed interface. + (slime-presentations-around-point): New. + (slime-same-presentation-p): Removed. + (slime-presentation-start-p, slime-presentation-stop-p): New. + (slime-presentation-start, slime-presentation-end): Changed to use + new text property layout. + (slime-presentation-bounds): New. + (slime-presentation-around-point): Reimplemented to handle nested + presentations. + (slime-for-each-presentation-in-region): New. + (slime-after-change-function): Use + slime-remove-presentation-properties and + slime-for-each-presentation-in-region. + (slime-copy-presentation-at-point): Complain if no presentation. + (slime-repl-insert-prompt): Don't put rear-nonsticky text property. + (slime-reify-old-output): Handle nested presentations. + (slime-repl-return): Use slime-presentation-around-or-before-point. + + Enable reification of presentations in non-REPL buffers. + + * slime.el (slime-buffer-substring-with-reified-output): New, + factored out from slime-repl-current-input. + (slime-repl-current-input): Use it here. + (slime-last-expression): Use it here. + + (slime-add-presentation-properties): Add text properties + modification-hooks et al. to enable self-destruction of incomplete + or edited presentations in non-REPL buffers. + +2005-08-15 Alan Ruttenberg <alanr-l(a)mumble.net> + + * slime.el (slime-goto-location-position) fix so the :method locator + regexp so that it can find eql specializers, (setf foo) methods, and to + allow (a single) newline between arguments in the arglist. + + * swank-openmcl.lisp (specializer-name) patch from Gary Byers and + Bryan O'Conner to fix complaint about certain classes slipping + through the etypecase + +2005-08-14 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-mark-presentation-end): Really remove the + presentation-start entry from the hash table. + + Merge some code from present.lisp, removing code duplication. + Minor code clean-up. + + * swank.lisp (*object-to-presentation-id*) + (*presentation-id-to-object*, clear-presentation-tables) + (*presentation-counter*, lookup-presented-object): Move here from + present.lisp. + (save-presented-object): Likewise. Assign negative numbers only, + so as not to clash with continuation ids. + + * swank.lisp (*repl-results*): Removed. + + * swank.lisp (get-repl-result, clear-repl-results): Use new + implementations from present.lisp. + (add-repl-result): Likewise, don't take the negative of the id. + (*last-repl-result-id*): New variable. + (clear-last-repl-result): Use it here. + + * slime.el (slime-repl-insert-prompt): Don't take the negative of + the id. + (slime-presentation-expression): New, take care to handle + arbitrary *read-base* settings. + (reify-old-output): Use it here. + (slime-read-object): Use it here. + +2005-08-12 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (substring-no-properties): Fix to handle non-zero start + argument correctly. + + Patch to remove use of the slime-repl-old-output text property in + favor of the slime-repl-presentation text property, in order to + simplify the code. + + * slime.el (slime-presentation-whole-p): Generalize to work with + strings too. + (slime-presentation-start, slime-presentation-end): Likewise. + (slime-presentation-around-point): Likewise. + (slime-presentation-around-or-before-point): New. + + * slime.el (reify-old-output): Use slime-repl-presentation + property and slime-presentation-around-point function rather than + slime-repl-old-output property. + (slime-repl-return): Use slime-repl-presentation rather than + slime-repl-old-output. + (slime-repl-grab-old-output): Use + slime-presentation-around-or-before-point. + (slime-read-object): Use slime-presentation-around-point. + + * slime.el (toplevel): Don't handle slime-repl-old-output text + property. + (slime-add-presentation-properties): Likewise. + (slime-after-change-function): Likewise. + +2005-08-12 Yaroslav Kavenchuk <kavenchuk(a)jenty.by> + + * swank-clisp.lisp (fspec-pathname): Use the documentation + function instead of accessing clisp internals. + +2005-08-11 Edi Weitz <edi(a)agharta.de> + + * swank.lisp (transpose-lists): Fixed it. + +2005-08-10 Alan Ruttenberg <alanr-l(a)mumble.net> + + * slime.el move slime-repl-add-to-input-history to + slime-repl-send-input so we can see the presentations we copied to + input when we reuse history rather than #.(blah...) + [Thanks Matthias! - was very busy and just returned to see your + changes merged. Most excellent.] + +2005-08-10 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-presentation-around-point): Change interface, + return presentation as primary return value. + (slime-copy-presentation-at-point): Use + slime-presentation-around-point. Copying now also works when the + first character is clicked and when the REPL buffer is not current. + (slime-presentation-menu): Use slime-presentation-around-point. + +2005-08-10 Martin Simmons <martin(a)lispworks.com> + + * swank-lispworks.lisp (defadvice compile-file): Return all values + from the real compile-file. + +2005-08-10 Edi Weitz <edi(a)agharta.de> + + * swank.lisp (transpose-lists): Replaced with much nicer function + by Helmut Eller. + +2005-08-09 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-read-object): Handle ids that are conses. + Patch by "Thas" on #lisp. + +2005-08-09 Edi Weitz <edi(a)agharta.de> + + * swank.lisp (transpose-lists): Reimplemented without APPLY so we + don't have problems with CALL-ARGUMENTS-LIMIT. + +2005-08-08 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (undo-in-progress): Define for XEmacs compatibility. + Reported by Friedrich Dominicus. + +2005-08-07 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Fix for the presentations menu. Reported by Aleksandar Bakic. + + * present.lisp (lookup-presented-object): Handle ids that are + conses. + (execute-menu-choice-for-presentation-id): Use equal for comparing + ids, to handle the cons case. + (menu-choices-for-presentation): Quote the presentation id, as it + can be a cons. + * slime.el (slime-presentation-menu, slime-presentation-menu) + (slime-inspect-presented-object): Quote the presentation id. + +2005-08-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (form-completion): New generic function, factored out + from complete-form. + (complete-form): Factor out form-completion. + (form-completion): Specialize on defmethod forms to insert arglist + of generic function. + + * doc/slime.texi (Programming Helpers): Document C-c C-s, + slime-complete-form. + +2005-08-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Improvements to the presentations feature. Parts of presentations + can be copied reliably using all available Emacs facilities (not + just kill-ring-save), and they are no longer "semi-readonly" (in + the sense that keypresses are silently ignored). Whenever a user + attempts to edit a presentation, it now simply turns into plain + text (which is indicated by changing the face); this can be + undone. Presentations are now also supported if + *use-dedicated-output-stream* is nil. It is now possible to + access the individual values of multiple-value results. For some + systems (Allegro CL and upcoming CMUCL snapshots), presentations + can be reliably printed through pretty-printing streams. + + * present.lisp (slime-stream-p) [allegro]: Allow printing + presentations through pretty printing streams. + [cmu]: Allow printing presentations through pretty printing + streams, if CMUCL has annotations support and we are using the + bridge-less protocol. + [sbcl]: Allow printing presentations through indenting streams. + + * present.lisp (write-annotation): New function. + (presentation-record): New structure. + (presentation-start, presentation-end): New functions, supporting + both bridge protocol and bridge-less protocol. + (presenting-object-1): Use them here. + + * present.lisp [sbcl, allegro]: Add printer hooks for unreadable + objects and pathnames. + + * swank.lisp (*can-print-presentation*): New variable, moved here + from present.lisp. + * swank.lisp (interactive-eval, listener-eval, backtrace) + (swank-compiler, compile-file-for-emacs, load-file) + (init-inspector): Bind *can-print-presentation* to an appropriate + value. + * present.lisp: Remove code duplication with swank.lisp for the + functions above. + + * swank.lisp (encode-message): Don't use the pretty printer for + printing the message length. + + * slime.el (slime-dispatch-event): New events :presentation-start, + :presentation-end for bridge-less presentation markup. + * swank.lisp (dispatch-event, send-to-socket-io): Likewise. + + * swank.lisp (listener-eval): Store the whole values-list with + add-repl-result. + * slime.el (slime-repl-insert-prompt): Accept a list of strings, + representing individual values of a multiple-value result. Mark + them up as separate presentations. + (reify-old-output): Support reifying individual values of a + multiple-value result. + + * slime.el (slime-pre-command-hook): Don't call + slime-presentation-command-hook. + (slime-post-command-hook): Don't call + slime-presentation-post-command-hook. + (slime-presentation-command-hook): Removed. + (slime-presentation-post-command-hook): Removed. + + * slime.el (slime-presentation-whole-p): New. + (slime-same-presentation-p): New. + (slime-presentation-start, slime-presentation-end): New. + (slime-presentation-around-point): New. + (slime-after-change-function): New. + (slime-setup-command-hooks): Install slime-after-change-function + as an after-change-function. + + * slime.el (slime-repl-enable-presentations): Make + slime-repl-presentation nonsticky. + (slime-mark-presentation-start, slime-mark-presentation-end): New + functions. + (slime-mark-presentation-start-handler): Renamed from + slime-mark-presentation-start. + (slime-mark-presentation-end-handler): Renamed from + slime-mark-presentation-end. + (slime-presentation): New structure. + (slime-add-presentation-properties): New function. + (slime-insert-presentation): New function. + +2005-08-03 Zach Beane <xach(a)gwi.net> + + * swank-sbcl.lisp (swank-compile-string): Restore honoring of + *trap-load-time-warnings*. + +2005-08-03 Juho Snellman <jsnell(a)iki.fi> + + * swank-sbcl.lisp: Remove SBCL 0.9.1 support. + (swank-compile-string): Funcall the compiled function outside + with-compilation-hooks to prevent runtime warnings from + popping up a *compiler-notes* buffer. + +2005-07-29 Marco Baringer <mb(a)bese.it> + + * doc/slime.texi (Other configurables): Document + *dedicated-output-stream-port*. + + * swank.lisp (*dedicated-output-stream-port*): New variable. + (open-dedicated-output-stream): Open the stream on the port + *dedicated-output-stream-port*. + + * slime.el (slime-set-default-directory): Fix typo in doc string. + +2005-07-26 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (inspect-for-emacs): Don't make whitespace + surrounding :action buttons part of the highlighted region. + + * slime.el (slime-goto-location-buffer): Put "SLIME Source Form" + buffer into Lisp mode. + +2005-07-26 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (compile-file-for-emacs): Accept optional + external-format arg. I frogot to commit this file on 2005-07-05. + + * slime.el (slime-input-complete-p): Skip over strings too. + +2005-07-26 Zach Beane <xach(a)xach.com> + + * swank-sbcl.lisp (swank-compile-string): Revert to old string + compilation behavior to fix compiler note annotations. Code from + Juho Snellman. + +2005-07-24 Tom Pierce <tlpierce(a)gmail.com> + + * swank.lisp (format-iso8601-time): New functions. Properly + formats a universal-time as an iso8601 string. + (inspect-for-emacs integer): Use the new + format-iso8601 function when printing an integer as a date. + +2005-07-22 Marco Baringer <mb(a)bese.it> + + * swank-openmcl.lisp (frame-catch-tags): Remove some debugging + forms which were "polluting" the repl buffer when viewing an sldb + buffer. + (function-source-location): Make :error messages have the proper + form (exactly one string argument). This fix also removes the + issues with sending unreadble lists (containing #<...> to emacs). + +2005-07-14 Helmut Eller <heller(a)common-lisp.net> + + * swank-allegro.lisp (find-external-format): Fix typo. + +2005-07-06 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-send-sigint): Use the symbol SIGINT stead of the + signal number. Suggested by Joerg Hoehle. + (slime-compile-file): XEmacs needs the buffer as argument to + local-variable-p. Reported by Andy Sloane. + +2005-07-05 Helmut Eller <heller(a)common-lisp.net> + + The file variable slime-coding can now be used to specify the + coding system to use for C-c C-k. E.g., if the file contains + -*- slime-coding: utf-8-unix -*- Emacs will tell the Lisp side + to call COMPILE-FILE with an external-format argument. + + * slime.el (slime-compile-file): Send the coding system if + the buffer local variable `slime-coding' is bound. + + * swank-backend.lisp, swank-sbcl.lisp, swank-clisp.lisp, + swank-lispworks.lisp, swank-cmucl, swank-allegro.lisp, + swank-abcl.lisp, swank-corman.lisp + (swank-compile-file): New optional argument `external-format'. + + * swank-clisp.lisp (getpid): Undo the last change. + + * swank-corman.lisp (spawn, thread-alive-p): More thread tweaking. + +2005-07-03 Joerg Hoehle <hoehle(a)users.sourceforge.net> + + * swank-clisp (describe-symbol-for-emacs): Report :setf and :type + where appropriate. + +2005-07-03 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (next-single-char-property-change) + (previous-single-char-property-change) [xemacs]: Only define them + if not present. + (next-char-property-change, previous-char-property-change): Define + if needed. + + * README: Show examples for the filenames instead of the general + "/the/path/to/this/directory". Suggested by Brandon J. Van Every. + + * swank-corman.lisp (default-directory): Return a namestring + instead of the pathname. + (inspect-for-emacs, inspect-structure): Teach the inspector how to + deal with structures. + (spawn, send, receive): Implement rudimentary threading support. + It's now possible to connect with the :spawn communication style + and to bring up a listener. Unfortunately, debugging the + non-primary threads doesn't work at all. Still no support for + interrupt-thread. + + * slime.el (slime-start-swank-server): Send an extra newline + before the "(swank:start-server ...". I don't know why, but this + seems to fix the problem when starting CLISP/Win32. Interrupting + CLISP/W32 is still horribly broken. + + * swank-loader.lisp (compile-files-if-needed-serially) [corman]: + force-output after each file. + +2005-07-02 Marco Baringer <mb(a)bese.it> + + * slime.el (save-some-lisp-buffers): New Function. + (slime-repl-only-save-lisp-buffers): New customizable variable. + (slime-repl-compile-and-load): Use save-some-lisp-buffers. + (slime-oos): Use save-some-lisp-buffers. + +2005-07-01 G�bor Melis <mega(a)hotpop.com> + + * swank-sbcl.lisp (threaded stuff): make SBCL 0.9.2.9+ work while + retaining support for 0.9.2 + +2005-06-28 G�bor Melis <mega(a)hotpop.com> + + * swank-sbcl.lisp (threaded stuff): horrible hack to make threaded + SBCL 0.9.2 work. (also, Happy Birthday Christophe!) + +2005-06-21 Edi Weitz <edi(a)agharta.de> + + * swank.lisp (find-matching-packages): Also use nicknames. + +2005-06-13 Edi Weitz <edi(a)agharta.de> + + * swank.lisp (list-all-systems-in-central-registry): Delete + duplicates. + + * swank-lispworks.lisp (unmangle-unfun): If you rename a package + you should rename it everywhere... + +2005-06-12 Alexey Dejneka <adejneka(a)comail.ru> + + * slime.el (slime-with-xref-buffer): fix "pgk" typo. + +2005-06-12 Christophe Rhodes <csr21(a)cam.ac.uk> + + * swank.lisp (ed-in-emacs): allow strings as well as pathnames; + don't call emacs for things that the emacs editor doesn't know how + to deal with. Return T if we called emacs and NIL if not. + + * slime.el (slime-ed): Change a listp to consp, so that NIL + arguments are correctly handled. + +2005-06-11 Nikodemus Siivola <nikodemus(a)random-state.net> + + * swank-sbcl.lisp: Patched for SBCL HEAD: utilize the new + :source-plist functionality; maintain compatibility with 0.9.1 + till 0.9.2 is out. Removed cruft left over from previous + excercises in supporting both HEAD and latest release. + + * doc/slime.texi: Document Slime as supporting the latest official + release of SBCL, as opposed to a specific version number which + would need to be updated monthly. + +2005-06-10 Helmut Eller <heller(a)common-lisp.net> + + * nregex.lisp (slime-nregex): Rename package to avoid name clashes + with other version of this file. + + * swank.lisp (compiled-regex): Use the new package name. + + * slime.el (slime-with-xref-buffer): Gensym package too, to avoid + problems when switching to buffers with -*- package: ... -*- file + variables. From Antonio Menezes Leitao. + (slime-property-bounds): Use the prop argument instead of the + hardcoded 'slime-repl-old-output. From Andras Simon. + +2005-06-07 Espen Wiborg <espenhw(a)grumblesmurf.org> + + * swank-corman.lisp: Convert to Unix line-endings. + (create-socket): Pass through the port argument unmodified, + gettting a random port if 0. Requires supporting change in + <ccl>/modules/sockets.lisp. + (inspect-for-emacs): defimplementation instead of defmethod. + +2005-06-06 Espen Wiborg <espenhw(a)grumblesmurf.org> + + * doc/slime.texi, PROBLEMS: Added notes about CCL. + +2005-06-03 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-background-activities-enabled-p): Allow + background stuff in repl-mode buffers too. + + * swank-cmucl.lisp (sis/misc): Return t for :interactive-p. + +2005-06-01 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-load-system, slime-oos): Fix bug related to file + locking. Don't bind the variable system-name. system-name is a + predefined Emacs variable and is used among other things for lock + filenames. + +2005-06-01 Joerg Hoehle <hoehle(a)users.sourceforge.net> + + * swank-clisp (getpid): Updates for current CLISP versions. Use + defimplementation. Define always (slime needs it). + +2005-06-01 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-background-activities-enabled-p): Return nil + instead of signalling an error if there is a open but no default + connection. + (slime-current-connection): New helper function. + (slime-connection): Use it. + (slime-first-change-hook): Only run when + slime-background-activities-enabled-p. + +2005-06-01 Joerg Hoehle <hoehle(a)users.sourceforge.net> + + * swank-cmucl.lisp, swank-sbcl.lisp, swank-clisp.lisp + (describe-symbol-for-emacs): Distinguish macro and special + operators from functions. + + * slime.el (slime-print-apropos): Must keep in sync with above, + therefore added :macro and :special-operator properties. + + * swank.lisp (present-symbol-before-p): Make it conform to its + specification -- sort first by package and then by symbol name. + + * swank-clisp.lisp (describe-symbol-for-emacs): Report :alien-type + when the name is known as foreign type. + +2005-06-01 Espen Wiborg <espenhw(a)grumblesmurf.org> + + * swank-loader.lisp: Redefine compile-files-if-needed-serially for + Corman Lisp to load everything from source. + +2005-05-27 Espen Wiborg <espenhw(a)grumblesmurf.org> + + * swank-corman.lisp: New file, swank for Corman Lisp. + + * swank.lisp (simple-announce-function): force-output after + announcing. + (symbol-external-p): Be extra paranoid about the symbol's package; + find-symbol barfs on a nil package in Corman Lisp. + + * swank-loader.lisp: Add Corman Lisp support. + +2005-05-24 Alan Ruttenberg <alanr-l(a)mumble.net> + + * slime.el text-property-default-nonsticky not defined in + xemacs. oops. + +2005-05-24 Alan Ruttenberg <alanr-l(a)mumble.net> + + * slime.el meta-w now removes properties before insertion if you + cut just a portion of the presentation. Added xemacs + support. Enabled in xemacs. + +2005-05-23 Alan Ruttenberg <alanr-l(a)mumble.net> + + * slime.el slime-presentation-menu - use with-current-buffer, so + that menus work even if you are not in the buffer with the + presentation. + + * present.lisp More menu items for pathnames. Remember last + slime-stream-p value. *can-print-presentation* t during + swank-compiler and during presentation menu action. + +2005-05-22 Alan Ruttenberg <alanr-l(a)mumble.net> + + * present.lisp. (slime-stream-p) check if a stream is destined for + output in a slime listener. (checks *connections* looks into pretty-print + streams in openmcl and cmucl) + Don't present unless (slime-stream-p stream). + + Variable *enable-presenting-readable-objects* The only readable object + which is presented are pathnames (e.g. pathnames printed when loading + and *load-verbose* is t). Try the useful menu :) + More to come if this doesn't cause problems. (nil this if it does) + + *can-print-presentation* t around compile-string-for-emacs, + load-file, interactive-eval. + + In cmucl, use fwrappers to modify behaviour rather than redefinition. + +2005-05-22 Alan Ruttenberg <alanr-l(a)mumble.net> + + * present.lisp. mouse-3 now gives a menu for actions on the + presentation. See documentation in file for information about how + to define menus. Also, disable presentations in inspector. Initial bits + of dealing with the possibility of presenting readable objects. + + * slime.el support menu. Xemacs users beware this uses x-popup-menu, + which may be fsf specific. + +2005-05-20 Alan Ruttenberg <alanr-l(a)mumble.net> + * swank.lisp make repl output presentation work even if + present.lisp not loaded + +2005-05-20 Luke Gorrie <luke(a)synap.se> + + * slime.el (slime-repl-enable-presentations): Default is enabled + in GNU Emacs but disabled in XEmacs. Feature is not portable yet. + Brutally 80-column'ified alanr's latest changes :-) + +2005-05-20 Alan Ruttenberg <alanr-l(a)mumble.net> + + * bridge.el new file. from ilisp cvs distribution to collect + in-band messages using process filter mechanisms. One edit which + calls bridge-insert with process argument as well as output + + * present.lisp new file. Enough code to do the following: + (swank::presenting-object object stream (print "This is really + object")). This makes the string "This is really object" behave + like old repl input for the object. Sample code for openmcl and + cmucl that hooks this into the printing of unreadable objects This + should be part of swank.lisp (and lisp specific files) but I am + too chicken to merge yet. For now you have to load this file + manually. + + * slime.el changes to support above: + slime-repl-enable-presentations: customize to enable this stuff. + Default value t. Set to nil to turn it off. + slime-presentation-start-to-point: map object ids to the (point) + where they start to print out. slime-mark-presentation-start, + slime-mark-presentation-end. handlers for the bridge messages. + slime-open-stream-to-lisp: When enabled start the bridge and + define the handlers. + +2005-05-19 Alan Ruttenberg <alanr-l(a)mumble.net> + + * slime.el slime-presentation-map + +2005-05-20 Luke Gorrie <luke(a)synap.se> + + * swank.lisp (clear-repl-results): Fixed unbalanced parens. Thanks + Lawrence Mitchell. + +2005-05-19 Alan Ruttenberg <alanr-l(a)mumble.net> + + * slime.el (slime-presentation-command-hook) new function for + nicer behaviour for presentations. + (slime-pre-command-hook) do slime-presentation-command-hook + (slime-post-command-hook) put pre-command-hook back if goes away + (slime-copy-presentation-at-point) mouse-2 copies previous output to point + slime-repl-output-mouseover-face what the old output looks like when the mouse moves over it + default: box around it like on lispm + (slime-repl-insert-prompt) add mouseover face, mouse action. newline after output not propertized. + (slime-property-bounds) adjust for lack of propertized newline + to fix: presentation region behaviour should be attach to generic property like + (:acts-as-token t ) rather than tying to repl-output property + +2005-05-19 Luke Gorrie <luke(a)synap.se> + + * swank.lisp (*record-repl-results*): Variable to enable/disable + recording of REPL results. True by default. + (*repl-results*): Renamed from ****. + + * slime.el (slime-property-bounds): Factored out this common part + of slime-repl-grab-old-{input,output}. + (slime-read-object): Avoid inline CL code. + +2005-05-18 Antonio Menezes Leitao <aml(a)gia.ist.utl.pt> + + * slime.el (slime-repl-inputed-output-face): new face. + (slime-current-output-id): New variable. + (slime-dispatch-event): Bind slime-current-output-id when + neccessary. + (slime-repl-insert-prompt): Add the neccessary text properties to + the result. + (reify-old-output): New function which makes sure swank sees + \(swank::get-**** ...) while the user sees the printed + representation of the object. + (slime-repl-return): When called on a old output (as per the + slime-repl-old-output text property, call + slime-repl-grab-old-output. + (slime-repl-send-input): Added the slime-repl-old-input text + property. + (slime-repl-grab-old-input): Keep the old input's text + properties (unwanted text properties are removed later). + (slime-repl-grab-old-output): New function. + (slime-repl-clear-buffer): Added call to swank::clear-**** + (slime-repl-clear-output): Added call to swank::clear-**** and + bind inhibit-read-only to nil. + (slime-inspect): Call slime-read-object to get the value to + inspect. + (slime-read-object): New function which either reads an object + from the minibuffer or returns the object at point if it has the + slime-repl-old-output text property. + + * swank.lisp (*current-id*, ****): New variables. + (add-****, get-****, clear-last-****, clear-****): New functions + for manipulating the repl history. + (listener-eval): Add * to ****. + +2005-05-12 Alan Ruttenberg <alanr-l(a)mumble.net> + + * swank.lisp Add ability to customize behavior of the repl. To do + so, add a function to the list swank::*slime-repl-eval-hooks*. + This function is passed the form typed into the repl. The function + should decide whether it wants to handle evaluation of the + form. If not, call (repl-eval-hook-pass) and the next hook is + tried. Otherwise the values the function returns are used instead + of calling eval. Inside the body of the function you can also + suppress having the repl print the result by calling + (repl-suppress-output) and/or suppress the advancement of the + history variables (*** ** * /// // /) by calling + (repl-suppress-advance-history). + + +2005-05-11 Tim Daly Jr. <tim(a)tenkan.org> + + * swank-source-path-parser.lisp (read-and-record-source-map): + Ensure that at least the toplevel form is in the source-map. + +2005-05-11 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-remove-old-overlays): Remove overlays in all + slime buffers not only in the current buffer. + (slime-filter-buffers): New helper. + (slime-display-completion-list): Take the completed prefix as + additional argument to initialize completion-base-size. This is + apparently needed to make mouse-selection working. + (slime-maybe-complete-as-filename): Factor for common code in + slime-complete-symbol* and slime-simple-complete-symbol. + +2005-05-06 Alan Ruttenberg <alanr-l(a)mumble.net> + + * swank-openmcl.lisp specializer-name didn't handle + structure-class which caused meta-. of methods specialized on + defstruct arguments to fail. + +2005-05-06 Helmut Eller <heller(a)common-lisp.net> + + * swank-cmucl.lisp (post-gc-hook): Include the elapsed time and + the size distribution. + +2005-05-05 Edi Weitz <edi(a)agharta.de> + + * swank-lispworks.lisp (unmangle-unfun): New function to convert + strange symbols in SETF package to SETF function names. + (signal-undefined-functions): Use it. + +2005-05-04 Edi Weitz <edi(a)agharta.de> + + * swank-lispworks.lisp (call-with-compilation-hooks): Provide + better implementation. + (compile-file-and-collect-notes): Advice for COMPILE-FILE so + pathname information for undefined functions can be recorded. + (*within-call-with-compilation-hooks*): New special variable used + by CALL-WITH-COMPILATION-HOOKS. + (*undefined-functions-hash*): New special variable to record + pathname information for undefined functions. + (signal-error-database): Make LOCATION parameter optional, use + FILENAME info from error database if not provided. + (signal-undefined-functions): Make LOCATION parameter optional, + use info from *UNDEFINED-FUNCTIONS-HASH* if not provided. + +2005-05-03 Luke Gorrie <luke(a)synap.se> + + * swank.lisp (slime-secret): Removed #+unix conditional, suggested + by Edi Weitz. + +2005-05-02 Mark Wooding <mdw(a)nsict.org> + + * swank.lisp: If ~/.slime-secret exists then insist that Emacs + sends the contents (as a password) during initial handshaking. + (announce-server-port): Use :IF-EXISTS :ERROR to prevent bad guys + from slipping a symlink into /tmp and reading what port Lisp is + listening on. + + * slime.el: If ~/.slime-secret exists then send it, as per above. + +2005-05-01 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-inspector-reinspect): New function which + reinspects the current object. + (slime-inspector-mode-map): Bind slime-inspector-reinspect to g. + +2005-04-29 Dan Pierson <dlp(a)itasoftware.com> + + * slime.el (slime-parse-context): Fix method parsing so that + pressing, say, C-c C-t when point is on a '-' in a symbol name + won't break. + (slime-browser-map): New variable. Add support for the common 'q' + keystroke to quit out of the xref. + (slime-fetch-browsable-xrefs): New function. Remove the (FLET ...) + entries which appear on at least CMUCL. I don't believe you can + actually expand them on any current implementation and they just + mess up the browse tree. Use only the method name when looking + up (METHOD ...) entries on CMUCL. This really shouldn't be here, + but I can't see how to avoid the error thrown by swank:xref. + (slime-expand-xrefs): Use it. + (slime-call-with-browser-setup): Initialize slime-buffer-package + properly. Previously, lisp-mode was called after setting it, but + lisp-mode clears all local variables, use lisp-mode-variables + instead. + + * swank-cmucl.lisp (toggle-trace): Be more carefully when tracing + methods: try both (METHOD ...) and (PCL:FAST-METHOD ...). + +2005-04-27 Helmut Eller <heller(a)common-lisp.net> + + * swank-cmucl.lisp (+header-type-symbols+): Drop the third arg to + apropos-list; it's no longer supported in recent CMUCLs. + +2005-04-21 Luke Gorrie <luke(a)synap.se> + + * swank.lisp (arglist-to-string): Rolled back the previous change + because it interferred with values appearing in parameter lists. + +2005-04-20 Luke Gorrie <luke(a)synap.se> + + * swank.lisp (arglist-to-string): Bind *PRINT-ESCAPE* to NIL. This + way symbols in arglists are printed as with PRINC, i.e. without + package qualifier. + + * swank-sbcl.lisp (preferred-communication-style): Use + `linux_no_threads_p' alien variable to decide whether to use + :SPAWN. From dan_b for compatibility with new SBCLs. + +2005-04-19 Helmut Eller <heller(a)common-lisp.net> + + * PROBLEMS: Warn about old kernels. + + * swank-backend.lisp: Fix some typos. + + * swank-sbcl.lisp (preferred-communication-style): Don't test for + sb-futex, it has lost its meaning in 0.8.21. + +2005-04-18 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (inferior-lisp-program): Defvar it here, in case it is + not defined in loaddefs and inf-lisp is not loaded. (That's the + case in XEmacs.) + + * mkdist.sh: update version number. + + * doc/slime.texi: Update version numbers for SBCL and ACL. + +2005-04-17 Peter Seibel <peter(a)gigamonkeys.com> + + * swank-loader.lisp (*implementation-features*): Added features + for GCL and ECL ... + (lisp-version-string): ... and code to compute version + string. (Supplied by someone who's email I've misplaced.) + +2005-04-14 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-selector): Discard input after sleeping. + +2005-04-09 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (sldb-get-buffer): Create a fresh buffer if there's no + buffer for the connection (and don't reuse an existing buffer even + if it has a matching name). + (slime-buffer-visible-p, slime-ir1-expand): Delete unused + functions. Mark some others as unused, but leave them there + because they are potentially useful. + + * swank.lisp (with-io-redirection, with-connection) + (with-buffer-syntax): Implement macros with `call-with' functions + to avoid some code bloat. + (call-with-connection, maybe-call-with-io-redirection) + (call-with-buffer-syntax): New functions. + (interactive-eval): Use from-string instead of read-from-string to + avoid problems whit *read-suppress*. + + * swank-sbcl.lisp: Add a few comments. + + * swank-abcl.lisp (print-frame): Trim whitespace to make the + backtrace look a bit terser. + +2005-04-07 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-net-coding-system): More fixes for + non-mule-XEmacsen. + (slime-net-coding-system): Even more fixes to make it for + mule-XEmacs. + +2005-04-05 Juergen Gmeiner <gj(a)gjdv.at> + + * swank-lisworks.lisp (find-top-frame): If we can't find an + invoke-debugger frame we take any old frame at the top. + +2005-04-04 James McIlree <ovrskeek(a)mac.com> + + * slime.el (find-coding-system, check-coding-system) + (process-coding-system, set-process-coding-system): Dummy + functions for no-mule-XEmacsen. + +2005-04-04 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-repl-show-maximum-output): New + function. Immitate the scrolling behavior of a terminal. + (slime-with-output-end-mark, slime-repl-return) + (slime-repl-send-input, slime-display-output-buffer): Use it + (slime-lisp-implementation-version, slime-machine-instance): New + connection variables. Suggested by Eduardo Mu�oz. + (slime-set-connection-info): Initialize them. + + * swank.lisp (connection-info): Include version and hostname in + the result. + + * swank-cmucl.lisp (breakpoint-values): Fixes for CMUCL-2005-03 + snapshot. + + * doc/slime.texi: Fix spelling errors. + + * cl-indent.el: Remove the file. Let the Emacs developers + maintain it. + +2005-04-01 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (sldb-get-buffer): Initialize the buffer local + variables slime-buffer-connection and slime-current-thread when + creating a fresh buffer. + + * swank.lisp (spawn-repl-thread): Use + *default-worker-thread-bindings* just like spawn-worker-thread. + (wrap-sldb-vars): New function. Rebind *sldb-level* to avoid + confusion with recursive errors during eval-in-frame. + (eval-string-in-frame, pprint-eval-string-in-frame): Use it. + + * swank-allegro.lisp (eval-in-frame): Allegro's + eval-form-in-context does nothing special with lexical variables + in the frame. Wrap an explicit LET around the form to get similar + behavior as in the other Lisps. + (inspect-for-emacs (structure-object)): Remove structure related + methods. It's already covered by the general case with + allegro-inspect. + (common-seperated-spec): Deleted + +2005-04-01 Luke Gorrie <luke(a)synap.se> + + * slime.el (slime-xref-mode): Summarise the most important + bindings in the mode description. + + * metering.lisp: Now supports only CLISP and OpenMCL. + Removed a lot of really ugly reader-conditionalized code, much of + it for archaic lisps (#+cltl2, #+lcl3.0, #+mcl1.3.2, etc). + + * swank-source-path-parser.lisp (check-source-path): Signal an + error if a source path is malformed. SBCL sometimes gives (NIL). + (source-path-stream-position): Use it. + + * slime.el (slime-goto-definition): Handle :error locations here + before any window/buffer changes are made. + +2005-04-01 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-keys): Bind slime-edit-definition-other-window + to `C-x 4 .' and slime-edit-definition-other-frame to `C-x 5 .', + shadowing the equivalent find-tag... bindings. + (slime-goto-definition): In the other-window and other-frame cases, + make sure point does not move in the originating window, even when + the definition is found in the same buffer. + +2005-03-31 Luke Gorrie <luke(a)synap.se> + + * doc/slime.texi (slime-selector): New section. + (Inspector): Updated for the post-1.0 inspector. + + * slime.el (slime-selector): Removed unneeded "the" prefixes in + descriptions of what the selector methods do. + +2005-03-27 Helmut Eller <heller(a)common-lisp.net> + + * PROBLEMS, NEWS, doc/slime.texi: Some updates for the upcoming + release. + +2005-03-27 Russell McManus <russell_mcmanus(a)yahoo.com> + + * swank-clisp.lisp (getpid): Try sys::process-id if + sys::program-id doesn't exist. + +2005-03-23 Marco Baringer <mb(a)bese.it> + + * swank.lisp (commit-edited-value): Read a backquated string, + instead of quating the result of read. This allows one to put + ,(form) into edit-value buffers. + +2005-03-22 Helmut Eller <heller(a)common-lisp.net> + + * swank-lispworks.lisp (swank-compile-string): Bind *print-radix* + to t, to avoid problems if somebody uses different values for + *print-base* and *read-base*. Reported by Alain Picard. + (emacs-connected): Add default methods for + environment-display-notifier and environment-display-debugger. + +2005-03-21 Helmut Eller <heller(a)common-lisp.net> + + * swank-sbcl.lisp (locate-compiler-note): Handle errors in macros + better. + (source-file-source-location): Read the snippet at the right + position. + + * swank-source-file-cache.lisp (read-snippet): Take the start + position as optional argument. + +2005-03-21 Helmut Eller <heller(a)common-lisp.net> + + * swank-sbcl.lisp (quit-lisp): If we are running multithreaded, + terminate all other threads too. (still broken in 0.8.20.27; used + to work in ~0.8.20.2.) + (with-debootstrapping, call-with-debootstrapping): Remove ugly + backward compatibility code. + (sbcl-source-file-p, guess-readtable-for-filename): New utilities. + (function-source-location): Handle work off to helper functions. + (find-function-source-location): New function. Use the + shebang-readtable for SBCL source files. + (function-source-position, function-source-filename) + (function-source-write-date, function-toplevel-form-number) + (function-hint-snippet, function-has-start-location-p) + (function-start-location): New helpers. + (safe-source-location-for-emacs): Don't catch errors if + *debug-definition-finding* is true. + (inspect-for-emacs): Minor beautifications. + + * swank.lisp (commit-edited-value): Use buffer syntax. + (compile-file-for-emacs, compile-string-for-emacs): Bind + *compile-print* to nil. + + * swank-cmucl.lisp (call-with-debugging-environment): Rebind + kernel:*current-level* 0. Useful for debugging pretty printer + code. + (inspect-for-emacs): Show details of interpreted functions. + +2005-03-21 Luke Gorrie <luke(a)synap.se> + + * swank-sbcl.lisp (function-source-location): For definitions + compiled in Emacs buffers, include the :emacs-string as a :snippet + hint for search-based M-. lookup. + +2005-03-21 Edi Weitz <edi(a)agharta.de> + + * swank-loader-lisp (*implementation-features*, *os-features*, + *architecture-features*): LispWorks was completely missing. + +2005-03-18 Luke Gorrie <luke(a)synap.se> + + * slime.el (slime-complete-symbol*-fancy): Now nil by default. + +2005-03-18 Helmut Eller <heller(a)common-lisp.net> + + * swank-source-path-parser.lisp (make-source-recording-readtable): + Ignore non-ascii chars. + + * swank-sbcl.lisp (swank-compile-string): Re-implemented. This + time with temp-files and proper source-location tracking. + (install-debug-source-patch, debug-source-for-info-advice): Patch + SBCL's debug-source-for-info so that we can dump our own bits of + debug info. + (function-source-location, code-location-source-path): Rewritten + to handle C-c C-c functions. Also use the source-path to locate + the position. + (locate-compiler-note): Renamed from resolve-note-location. + (temp-file-name, call/temp-file): New utilities. + (file-source-location, lisp-source-location) + (temp-file-source-location, source-file-source-location) + (string-source-position, code-location-debug-source-info) + (code-location-debug-source-name, code-location-debug-source-created,) + (code-location-debug-fun-fun, code-location-from-emacs-buffer-p) + (function-from-emacs-buffer-p, function-debug-source-info) + (info-from-emacs-buffer-p, code-location-has-debug-block-info-p) + (stream-source-position): Lots of new helper functions. + (with-debootstrapping): Moved upwards so that it can be used for + source location searching. + (source-location-for-emacs): Deleted + +2005-03-16 Helmut Eller <heller(a)common-lisp.net> + + * slime/swank.lisp (*macroexpand-printer-bindings*): New user + variable. + (apply-macro-expander): Use it. + (call-with-bindings): Bind variables in reverse order. Thit makes + it easer to cons or push a new binding at the front the list. + (with-bindings): New macro. + + * slime.el (slime-run-when-idle): New function to hide + Emacs/XEmacs differences. + (slime-process-available-input): Use it. + + * swank-loader.lisp (unique-directory-name): Rewritten to avoid + the rather irritating warning that (warn "Don't know ...") is + unreachable. + +2005-03-13 Luke Gorrie <luke(a)synap.se> + + * slime.el (slime-dispatch-event): Use `slime-busy-p' to control + the "; pipelined request" message. This way it takes requests + blocked in the debugger into account and avoids spurious messages. + + * swank.lisp (inspect-for-emacs symbol): Add an "unintern it" + action for symbols. + + * swank-source-file-cache.lisp (read-snippet): Skip comments and + whitespace in SBCL. The source-positions reported by SBCL are not + adjusted to skip over whitespace before the definition. + + * swank-sbcl.lisp (function-source-location): Updated for revised + sb-introspect patch: + s/DEFINITION-SOURCE-CREATED/DEFINITION-SOURCE-WRITE-DATE/ + + * swank-loader.lisp (*os-features*): Added :mswindows. Thanks Will + Glozer. + +2005-03-12 Luke Gorrie <luke(a)synap.se> + + * slime.el (slime-edit-value): New function on `C-c E'. Prompts + for a Lisp expression, evaluates and displays the result in a new + buffer for editing, and then setf's the edited value in Lisp after + you press C-c C-c. Usage example: `C-c E asdf:*central-registry*' + Minor docstring and pull-down-menu changes. + + * swank.lisp (value-for-editing, commit-edited-value): New + functions for slime-edit-value. + + * swank-allegro.lisp (toggle-trace): Fix from Antonio Menezes + Leitao. + + * swank-sbcl.lisp: Use swank-source-file-cache to find snippets of + definitions. M-. is now much more robust to modifications in the + source file. + NOTE: To be effective requires a patch to sb-introspect that I + have posted to sbcl-devel. + + * swank-source-file-cache.lisp: Factored this into its own file, + from swank-cmucl.lisp. + + * swank-loader.lisp, swank-cmucl.lisp: Updated for the above. + +2005-03-10 Antonio Menezes Leitao <aml(a)gia.ist.utl.pt> + + * slime.el (slime-toggle-trace-fdefinition): If there is no symbol + at point then prompt for one. + +2005-03-09 Peter Seibel <peter(a)gigamonkeys.com> + + * swank-loader.lisp (*architecture-features*): Added :pc386 for CLISP. + (unique-directory-name): Change ERROR to WARN. + + * slime.el (slime-register-lisp-implementation): Add facility for + registering lisp implementations with symbolic names that can be + passed to C-u M-x slime. + +2005-03-08 Peter Seibel <peter(a)gigamonkeys.com> + + * doc/Makefile (clean): added clean and really_clean targets. + (all): and added slime.pdf to all prerequisites. + + * swank-loader.lisp (*implementation-features*): Whoops. Forgot + CLISP. + (*architecture-features*): Added :x86-64 for SBCL on AMD64 (thanks + Vincent Arkesteijn) + +2005-03-07 Peter Seibel <peter(a)gigamonkeys.com> + + * swank-loader.lisp (unique-directory-name): Replaced *lisp-name* + variable with more sophisticated version that accounts for impl, + impl version, os, and hardware architecture. + +2005-03-07 Edi Weitz <edi(a)agharta.de> + + * swank.lisp: Fixed parenthesis-balancing problem. + +2005-03-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-easy-menu): Add menu item for + slime-complete-form. + + * swank.lisp (format-arglist-for-echo-area): Use extra-keywords to + enrich the list of keywords. + (arglist-to-string): Remove extraneous whitespace. + (keyword-arg, optional-arg): New structures. + (decode-keyword-arg, decode-optional-arg): Return structure + objects rather than multiple values. + (encode-keyword-arg, encode-optional-arg, encode-arglist): New + functions. + (arglist): New slot key-p. + (decode-arglist): Handle &whole, &environment. Store more + information on optional and keyword args, set arglist.key-p. + (values-equal?): Removed. + (print-decoded-arglist-as-template): If keyword is + not a keyword symbol, quote it in the template. + (extra-keywords): Return a secondary value (allow-other-keys). + For make-instance, try to finalize the class if it is not + finalized yet (fix for Allegro CL 6.2). If class is not + finalizable, use direct slots instead of slots and indicate that + the keywords are not complete. + (enrich-decoded-arglist-with-extra-keywords): New function, use + the secondary value of extra-keywords. + (arglist-for-insertion, complete-form): Use it here. + (remove-keywords-alist): New variable. + (remove-actual-args): When the keyword :test is provided, don't + suggest :test-not and vice versa. + + * swank-backend.lisp (:swank-mop package): Export + finalize-inheritance. + +2005-03-06 Luke Gorrie <luke(a)synap.se> + + * swank.lisp: Export *LOG-OUTPUT*. + +2005-03-05 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-net-sentinel): Always print a message when the + lisp disconnects. + (slime-inferior-lisp): Don't display the buffer. Let callers do + that. + (slime): Display the inferior buffer here. + (slime-quit-lisp, slime-quit-sentinel): Use set a special sentinel + and do most of the cleanups there. + (slime-repl-sayoonara): Use slime-quit-lisp. + (slime-restart-inferior-lisp, slime-restart-inferior-lisp-aux) + (slime-restart-sentinel): Use a special sentinel to restart + processes. + (slime-hide-inferior-lisp-buffer): Do the windows arrangement a + bit differently. Related to restart-lisp. + (slime-repl-buffer): Take the connection as second optional + argument. Useful for rearranging windows for dead processes. + + * swank-allegro.lisp (call-with-debugging-environment) + (find-topframe): Hide the first 2 frames. Those are created + by swank-internal functions. + +2005-03-04 Antonio Menezes Leitao <aml(a)gia.ist.utl.pt> + + * swank-allegro.lisp (process-fspec-for-allegro, toggle-trace): + Handle setf functions. + (tracedp): Fix free variable. + + * slime.el (slime-trace-query): The :defgeneric query was bogus. + (slime-extract-context): Don't skip over the method name if we are + already at the end of the name. + +2005-03-03 Nikodemus Siivola <tsiivola(a)cc.hut.fi> + + * swank-sbcl.lisp: Fixed for latest SBCL HEAD revision and + temporarily backwards-compatible with the current release. + +2005-03-02 Marco Baringer <mb(a)bese.it> + + * swank-loader.lisp Look for a file in the same directory as + swank-loader.lisp called site-init.lisp. If it exists we load that + instead of attempting to load ~/.swank.lisp. + (user-init-file): Superseded by load-user-init-file. + (load-user-init-file): New function. + (load-site-init-file): New function. + +2005-03-01 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-who-bindings): Bind who-specializes to C-c W a. + (slime-extract-context): Renamed from name-context-at-point. + (slime-beginning-of-list): Renamed from out-first. + (slime-slime-parse-toplevel-form): Renamed from definition-name. + (slime-arglist-specializers): Renamed from parameter-specializers. + (slime-toggle-trace-function, slime-toggle-trace-defgeneric) + (slime-toggle-trace-defmethod, slime-toggle-trace-maybe-wherein) + (slime-toggle-trace-within): Deleted. Everything is now handled + by slime-trace-query. + (slime-calls-who): For symmetry with silme-who-calls. + (slime-edit-definition-with-etags): Better intergration with TAGS. + (slime-edit-definition-fallback-function): Mention it in the + docstring. + + * swank-backend (calls-who, toggle-trace): New functions. + (toggle-trace-function, toggle-trace-generic-function-methods, + (toggle-trace-method, toggle-trace-fdefinition-wherein): Replaced + by toggle-trace. + + * swank.lisp (*sldb-printer-bindings*, *swank-pprint-bindings*): + New variables. The alists replace the variables which where + previously hidden with the define-printer-variables macro. + (define-printer-variables, with-printer-settings): Deleted, + because the variable names where not visible in the source code. + (swank-toggle-trace): Renamed from toggle-trace-fdefinition. + + * swank-cmucl.lisp, swank-lispworks, swank-sbcl.lisp, + swank-allegro.lisp (toggle-trace): Update tracing code for new + interface. + +2005-02-24 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-dispatch-event): Add :eval-no-wait and :eval + events. + (slime-eval-for-lisp): New function. + (sldb-buffers): Delete the variable. Use buffer-list instead. + + * swank.lisp: (eval-for-emacs): Use the new backend function + call-with-debugger-hook. + (eval-in-emacs): Cleaned up. Add support for synchronous RPCs. + (receive-eval-result): New function. + (dispatch-event, read-from-socket-io, send-to-socket-io): New + :eval event. Rename :%apply to :eval-no-wait. + (read-user-input-from-emacs, evaluate-in-emacs): Increment + *read-input-catch-tag* instead of re-binding it. Reduces the + danger of throwing to the wrong tag a bit. + + * swank-backend.lisp (call-with-debugger-hook): New function. + Useful if the backend needs special incantations for BREAK. + (toggle-trace-function): Add a default implementation for simple + symbols. + + * swank-lispworks.lisp (slime-env): New class. + (call-with-debugger-hook): Use env:with-environment to pop up our + debugger on a BREAK. + (toggle-trace-method, parse-fspec, tracedp, toggle-trace): + Implement method tracing. + + * swank-sbcl.lisp (call-with-debugger-hook): Bind + sb-ext:*invoke-debugger-hook* instead of setting it in + emacs-connected. + (emacs-connected): Deleted. + + * swank-loader.lisp (compile-files-if-needed-serially): Reduce + verbosity by setting the :print argument for compile-file to nil. + +2005-02-23 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-startup-animation, slime-repl-update-banner): + Put the animation back in to keep the kids quiet. + (slime-kill-without-query-p): Change default to nil. + (slime-eval-describe, slime-eval-region) + (slime-pprint-eval-last-expression): Fix typos in docstrings. + (slime-eval/compile-defun-dwim): Deleted. We never had a key + binding anyway. + +2005-02-22 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-complete-form): Emacs 20 compatibility fix. + (slime-repl-update-banner): Remove animation stuff. + (slime-startup-animation): Deleted. + + * swank-lispworks.lisp (compute-applicable-methods-using-classes): + Implement it. + +2005-02-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Supersede the command slime-insert-arglist with the new command + slime-complete-form and bind it to C-c C-s. The command completes + an incomplete form with a template for the missing arguments. + There is special code for discovering extra keywords of generic + functions and for handling make-instance. Examples: + + (subseq "abc" <C-c C-s> + --inserts--> start [end]) + (find 17 <C-c C-s> + --inserts--> sequence :from-end from-end :test test + :test-not test-not :start start :end end :key key) + (find 17 '(17 18 19) :test #'= <C-c C-s> + --inserts--> :from-end from-end + :test-not test-not :start start :end end :key key) + (defclass foo () ((bar :initarg :bar))) + (defmethod initialize-instance :after ((object foo) &key blub)) + (make-instance 'foo <C-c C-s> + --inserts--> :bar bar :blub blub initargs...) + + * swank.lisp (arglist): New struct for storing decoded arglists. + (decode-arglist): New function. + (arglist-keywords, methods-keywords, generic-function-keywords, + applicable-methods-keywords): New functions. + (decoded-arglist-to-template-string, + print-decoded-arglist-as-template): New functions. + (arglist-to-template-string): Rewrite using above functions. + (remove-actual-args): New function. + (complete-form): New slimefun. + + * swank.lisp (extra-keywords): New generic function. + + * swank-backend.lisp (:swank-mop package): + Export compute-applicable-methods-using-classes. + + * swank.lisp (arglist-for-insertion): Use extra-keywords to + enrich the list of keywords. + + * swank.lisp (valid-operator-symbol-p): New function. + (valid-operator-name-p): Use valid-operator-symbol-p. + + * slime.el (slime-complete-form): New command. + (slime-keys): Bind C-c C-s to slime-complete-form rather than + slime-insert-arglist. + +2005-02-18 Antonio Menezes Leitao <aml(a)gia.ist.utl.pt> + + Improve the trace mechanism (on lisps that support it). SLIME is + now able to trace/untrace flet/labels functions, methods and, of + course, regular and generic functions. + + In the process support for sending code to emacs form the lisp was + added. The code, elisp forms, is sent over the wire like normal + lisp code, evaluated in emacs and the return value is returned + back to the lisp. + + * slime.el (slime-dispatch-event): Added the :evaluale-in-emacs + dispatch state which simply parses the message and class + evaluate-in-emacs. + (evaluate-in-emacs): New function. + (complete-name-context-at-point, name-context-at-point, out-first, + definition-name, parameter-specializers, + slime-toggle-trace-fdefinition, slime-toggle-trace-function, + slime-toggle-trace-defgeneric, slime-toggle-trace-defmethod, + slime-toggle-trace-maybe-wherein, slime-toggle-trace-within): New + functions implementing the new intelligent slime trace. + + * swank-backend.lisp (toggle-trace-function, + toggle-trace-generic-function-methods, toggle-trace-method, + toggle-trace-fdefinition-wherein, + toggle-trace-fdefinition-within): New backend functions + for the new trace facility. + + * swank.lisp (dispatch-event): Handle the :evaluate-in-emacs + message type. + (evaluate-in-emacs): New function. + + * swank-allegro.lisp (toggle-trace-generic-function-methods, + toggle-trace, toggle-trace-function, toggle-trace-method, + toggle-trace-fdefinition-wherein, + toggle-trace-fdefinition-within): Implement. + (process-fspec-for-allegro): New function. + + * swank-cmucl.lisp (toggle-trace-generic-function-methods, + toggle-trace-function, toggle-trace-method, + toggle-trace-fdefinition-wherein): Implement. + (toggle-trace, process-fspec): New functions. + + * swank-sbcl.lisp (toggle-trace-generic-function-methods, + toggle-trace-function, toggle-trace-method, + toggle-trace-fdefinition-wherein): Implement. + (toggle-trace, process-fspec): New functions. + +2005-02-02 Helmut Eller <heller(a)common-lisp.net> + + * slime.el: Require the timer package explicitly. + +2005-02-02 Luke Gorrie <luke(a)synap.se> + + * slime.el (slime-repl-send-input): Move some properties + of old REPL input (e.g. read-only) from text properties into an + overlay, so that kill/yank will leave them behind. Left + `slime-repl-old-input' as a text properties because it's more + convenient to lookup that way. + (slime-repl-return): Ignore `slime-repl-old-input' property if the + point is in front of the current REPL prompt, i.e. if the user has + copy&pasted some old REPL input into the current input area. + +2005-01-30 Bryan O'Connor <bryan-slime(a)lunch.org> + + * slime.el (slime-goto-location-position): Changed the regexp to + require the function-name to be followed by a + non-symbol-constituent character \S_. Previously, a function-name + of "find" first matched find-if-not if it occured earlier in the + file. + +2005-01-27 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-busy-p): Ignore debugged continuations to enable + arglist lookup while debugging. Suggested by Lynn Quam. + (sldb-continuations): New buffer local variable in sldb buffers to + keep track of debugged continuations. + (sldb-debugged-continuations): New function. + (sldb-buffers): Renamed from sldb-remove-killed-buffers. + (slime-eval-print): New function to insert the stream output and + the result of an evaluation in the current buffer. + (slime-eval-print-last-expression): Use it. + (slime-interactive-eval): Use slime-eval-print when a prefix + argument was given. + + * swank.lisp (*pending-continuations*, eval-in-emacs) + (debugger-info-for-emacs): Keep track of debugged continuation the + new variable *pending-continuations* and include the list of + active continuations in the debugger info for Emacs. + (eval-and-grab-output): New function. Used by slime-eval-print. + (*log-output*): Renamed from *log-io*. Use *standard-error* as + initial value instead of *terminal-io*. CMUCL opens its own tty + and that makes it hard to redirect to output with a shell. + *standard-error* writes its output to file descriptor 2. + (*canonical-package-nicknames*): Fix typo. + +2005-01-20 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (parse-symbol): Don't break if the package doesn't + exist. Reported by Lynn Quam. + +2005-01-20 Ian Eslick <eslick(a)csail.mit.edu> + + * swank-allegro.lisp (restart-frame): Handle frames with arguments + better. + +2005-01-20 Edi Weitz <edi(a)agharta.de> + + * swank-allegro.lisp (handle-undefined-functions-warning): Prevent + breakage if the undefined function is called at multiple + locations. + +2005-01-19 Helmut Eller <heller(a)common-lisp.net> + + * swank-gray.lisp (stream-unread-char): If the char argument + doesn't match the contents in the buffer, ignore it and emit a + warning instead. + +2005-01-19 Utz-Uwe Haus <haus+slime(a)merkur.math.uni-magdeburg.de> + + * swank-cmucl.lisp (breakpoint): Add a slot for return values to + make return values inspectable in the debugger. + (signal-breakpoint): Initialize the new slot. + +2005-01-19 Matthias Koeppe <mkoeppe(a)merkur.math.uni-magdeburg.de> + + * slime.el (slime-insert-arglist): Inserts a template for a + function call instead of the plain arglist; this makes a + difference for functions with optional and keyword arguments. + + * swank.lisp (arglist-to-template-string): New function. + (arglist-for-insertion): Use it + (decode-keyword-arg, decode-optional-arg): New functions. + +2005-01-19 Lars Magne Ingebrigtsen <larsi(a)gnus.org> + + * slime.el (slime-header-line-p): Customize variable to + enable/disable the header-line in the REPL. + +2005-01-18 Luke Gorrie <luke(a)synap.se> + + * slime.el (slime-complete-symbol*-fancy): New variable to enable + extra bells and whistles with slime-complete-symbol*. Currently + controls whether to use arglists semantically. Default is t. + (slime-complete-symbol*-fancy-bit): Factored out this function. + Only do "semantic" completion when the symbol is in + function-position, avoid interning argument names in Emacs, and + don't display arglists if the minibuffer is active. + +2005-01-14 Luke Gorrie <luke(a)synap.se> + + * slime.el (slime-repl-send-input): Make old input read-only using + an overlay instead of a text property. This way if you copy&paste + the input elsewhere it will become editable (overlay is associated + with the buffer region and not the text). + +2005-01-14 Edi Weitz <edi(a)agharta.de> + + * slime.el (slime-complete-symbol*): Maybe insert closing + parenthesis or space (depending on arglist) after symbol + completion has finished. Optionally also show arglist. + +2005-01-13 Helmut Eller <heller(a)common-lisp.net> + + * swank-cmucl.lisp (create-socket): The byte-order of the :host + argument for CREATE-INET-LISTENER was changed in the Jan 2005 + snapshot. Test whether the symbol 'ext:socket-error exists to + decide if we are in a older version. + (resolve-hostname): Return the address in host byte-order. + +2005-01-12 Robert Lehr <bozzio(a)the-lehrs.com> + + * slime.el (slime-changelog-date): Return nil if the ChangLog file + doesn't exits. + (slime-repl-update-banner): Write "ChangeLog file not found" if + the ChangeLog doesn't exist. + +2005-01-12 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime.el (slime-inspector-operate-on-click): New command for + inspecting the value value at the clicked-at position or invoking + an inspector action. + (slime-inspector-mode-map): Bind it to mouse-2. + (slime-inspector-insert-ispec): Add mouse-face properties for + clickable values and action buttons. + +2005-01-12 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (*default-worker-thread-bindings*): New variable to + initialize dynamic variables in worker threads. + (spawn-worker-thread, call-with-bindings): New helper functions. + (thread-for-evaluation): Use them. + +2005-01-10 Utz-Uwe Haus <haus+slime(a)merkur.math.uni-magdeburg.de> + + * swank-sbcl.lisp (profile-package): Add implementation for SBCL. + +2005-01-10 Eduardo Mu�oz <emufer(a)terra.es> + + * swank.lisp (inspect-for-emacs-list): LispWorks has a low args + limit for apply: use reduce instead of apply. + +2005-01-10 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-conservative-indentation): The default is now + nil. Suggested by Travis Cross. + +2005-01-10 Matthias Koeppe <mkoeppe(a)merkur.math.uni-magdeburg.de> + + * slime.el (slime-inspector-next-inspectable-object): Accept a + prefix argument and make wrapping around more reliable. The code + is adapted from `widget-move'. + (slime-inspector-previous-inspectable-object): New command. + (slime-inspector-mode-map): Bind to S-TAB. + +2004-12-16 Martin Simmons <martin(a)xanalys.com> + + * swank-lispworks.lisp (create-socket): Work around bug in + comm::create-tcp-socket-for-service on Mac OS LW 4.3. + +2004-12-16 Edi Weitz <edi(a)agharta.de> + + * slime.el (slime-complete-symbol*): Bind + comint-completion-addsuffix so unambiguous or exact completion + closes the string automatically. + +2004-12-16 Matthias Koeppe <mkoeppe(a)merkur.math.uni-magdeburg.de> + + * slime.el (slime-keys): Bind M-* to + slime-pop-find-definition-stack for compatibility with standard + Emacs conventions. + +2004-12-16 Helmut Eller <heller(a)common-lisp.net> + + * swank-source-path-parser.lisp (read-source-form): New function + which uses *read-suppress* properly. Common code from + source-path-stream-position and form-number-stream-position. + (source-path-stream-position): Use it. + + * swank-cmucl.lisp (form-number-stream-position): Use + read-source-form. + + * swank.lisp (frame-for-emacs): Print the frame number a little + nicer with ~2D. + +2004-12-15 Matthias Koeppe <mkoeppe(a)merkur.math.uni-magdeburg.de> + + * slime.el (slime-lisp-modes): New variable to make C-c C-k + customizable and usable in scheme-mode. + (slime-compile-file): Use it. + +2004-12-15 Helmut Eller <heller(a)common-lisp.net> + + * swank-cmucl.lisp, swank-backend.lisp (frame-package): Delete it. + Include the package name for local variables because it is utterly + confusing if `eval-in-frame' doesn't work due to missing package + prefixes. + + * swank-source-path-parser.lisp (source-path-stream-position): + Bind *read-suppress* to nil before calling + read-and-record-source-map. + + * swank-clisp.lisp (*buffer-name*, *buffer-offset*): Move + definitions upward before the first use. + +2004-12-15 Bryan O'Connor <bryan-slime(a)lunch.org> + + * slime.el (slime-edit-definition): Switch to the other frame if + the `where' is 'frame. + (slime-edit-definition-other-frame): New function. + +2004-12-15 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-repl-send-input): Make the input read-only to + avoid confusion. + (slime-make-region-read-only): New function. + +2004-12-13 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-repl-mode-map): Bind <home> to slime-repl-bol. + Suggested by Chris Capel. + (slime-repl-grab-old-input): Remove the 'old-input text-property + from the copied text. Reported by Tim Oates. + (slime-repl-grab-old-input): Append the old input to the current + input by default. If the new `replace' argument is true, replace + the current input. Suggested by Antonio Menezes Leitao. + (slime-repl-return): Pass the prefix argument to + slime-repl-grab-old-input. + +2004-12-09 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (*sldb-print-pretty*, *sldb-print-circle*) + (*sldb-print-length*, *sldb-print-level*, *sldb-print-lines*) + (*sldb-print-pprint-dispatch*): Export those symbols. + +2004-12-05 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-global-variable-name-p): Also return true for + names of constants like +foo+. Suggested by Christian Lynbech. + + * swank-allegro.lisp (handle-compiler-warning): Handle + undefined-functions warnings by looking the fromat-arguments of + the condition. + (compiler-undefined-functions-called-warning-p) + (location-for-warning, handle-undefined-functions-warning): New + functions. + + * swank-cmucl.lisp (*install-gc-hooks*): New user variable. + (sending-safe-p): New predicate. + (pre-gc-hook, post-gc-hook): Use it. + + * swank.lisp (eval-region): Use a simple loop. + +2004-12-02 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp: (inspect-for-emacs (symbol)): Handle non-interned + symbols. + + * slime.el (slime-repl-clear-buffer, slime-repl-clear-output): Fix + docstrings. + +2004-11-29 Lynn Quam <quam(a)ai.sri.com> + + * slime.el (slime-global-variable-name-p): Allow optional + "<package-name>:" or "<package-name>::". + +2004-11-29 Chris Capel <pdf23ds(a)gmail.com> + + * swank.lisp (macro-indentation): Ignore &whole, &aux, and + &environment args. + +2004-11-29 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-repl-wrap-history): New user variable. + (slime-repl-history-replace): Implement wrap around. + (slime-repl-easy-menu): Fix binding for "Next Input". Reported by + Surendra Singhi. + + * swank-lispworks.lisp (list-callers-internal): Return the + function if dspec:object-dspec returns nil. + (xref-results): Previously, functions for which + dspec:dspec-definition-locations returned nil were ignored. + Include them with a unknown source-location. + + * swank-abcl.lisp, swank-allegro.lisp, swank-clisp.lisp, + swank-cmucl.lisp, swank-openmcl.lisp, swank-sbcl.lisp, + swank-lispworks (accept-connection): The :external-format argument + defaults now to :iso-latin-1-unix. + +2004-11-26 Helmut Eller <heller(a)common-lisp.net> + + * swank-cmucl.lisp (read-into-simple-string): Use #-cmu19 instead + of #+cmu18e. + +2004-11-25 Chris Capel <pdf23ds(a)gmail.com> + + * slime.el (slime-indent-and-complete-symbol): Echo the arglist if + there's no symbol before point. Don't complete after parens. + (slime-echo-arglist): Factorized from slime-space. + (slime-space): Use it. + (slime-repl-history-replace): Clear the input at the end of the + history. + + * swank.lisp (arglist-to-string): Don't show &whole, &aux and + &environment args. + (clean-arglist): New function. + +2004-11-25 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-net-coding-system): Emacs does funky encoding + for `raw-text-unix' use `binary' instead. + (slime-safe-encoding-p): New function. + (slime-net-send): Use it and don't try to send stuff which can't + be decoded by Lisp. + (slime-inferior-lisp-program-history): XEmacs compatibility: + declare it as a variable. + (slime-xref-mode): In Emacs 21, set delayed-mode-hooks to nil + because we don't want to run the lisp-mode-hook. Reported by + Chris Capel. + + * swank.lisp (dispatch-loop): Catch errors and close the + connection. It's almost impossible to run the debugger inside the + control-thread, so let it crash instead. A backtrace would be + nice, though. + (cleanup-connection-threads): Can now be called in the + control-thread. Add a check to avoid thread suicide. + (start-swank-server-in-thread): Fix the call to start-server. + + * swank-sbcl.lisp (%thread-state-slot, %thread-state): Refactored + from thread-status. + (thread-status): Use it. + (all-threads): Exclude zombies. + +2004-11-24 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-start-and-load): Use vanilla comint instead of + inf-lisp. Let's try that for a while. + (slime): Ask for the coding system when invoked with C-u C-u. + (slime-net-coding-system, slime-net-valid-coding-systems): Add + some alternatives for older Emacsen. + (slime-find-buffer-package): Skip quotes. Old code looks + sometimes like (in-package 'foo). + (slime-repl-mode-map): Inhibit C-c C-z. Avoids accidental loading + inf-lisp. + (slime-net-coding-system): Use find-coding-system in XEmacs. + coding-system-p means something different here. + (slime-repl-mode-map): XEmacs compatibility: use (kbd "C-<up>") + instead of [C-up]. + + * swank.lisp (inspect-for-emacs-list): subseq on improper lists + breaks in Lispworks. Handle that case better. + + * swank-sbcl.lisp (inspect-for-emacs)[code-component]: Disassemble + code-components too. + + * swank-backend.lisp (import-swank-mop-symbols): Better error + message for the assertion. + + * swank-cmucl.lisp (debug-var-value): Return #:invalid or + #:unknown instead of :<not-available>. + (swank-compile-file): Load the fasl file only if load-p is true. + (inspect-for-emacs, inspect-alien-record, inspect-alien-pointer): + Add inspector support for some alien types. + + * swank-lispworks.lisp (emacs-connected): Set the sigint handler + only for single threaded operation. I.e. when + *communication-style* is nil. + + * swank-allegro.lisp (set-external-format): New function. Use LF + as eol mark. + (call-with-compilation-hooks): Trap compiler-notes too. + +2004-11-24 Luke Gorrie <luke(a)synap.se> + + * slime.el (slime-repl-mode-map): Add C-up and C-down to move + through history. Consistent with comint-mode. + (slime-repl-mode-map): Add slime-load-file on `C-c C-l' and + slime-compile-file on `C-c C-k'. This is mostly to override + unwanted inf-lisp bindings in lisp-mode-map. + (slime-load-file): Handle (buffer-file-name) being nil. + +2004-11-20 Helmut Eller <heller(a)common-lisp.net> + + * swank-sbcl.lisp (make-socket-io-stream): Add some #+sb-unicode. + +2004-11-20 Travis Cross <travis(a)crosswirecorp.com> + + * swank-sbcl.lisp (thread-status): Fix unbalanced parenthesis. + +2004-11-20 Marco Baringer <mb(a)bese.it> + + * swank-openmcl.lisp (make-stream-interactive): Only add ouptut + streams (subclasses of ccl:fundamental-output-stream) to + ccl::*auto-flush-streams*. + +2004-11-19 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-net-coding-system): New variable. Specifies the + coding system to use for network communication. The default is + iso-latin-1 and should work for all Lisps. Only a small set of + coding systems is currently supported. + (slime-net-valid-coding-systems): New variable. A list of coding + systems which may be used. + (slime-check-coding-system, slime-coding-system-mulibyte-p) + (slime-coding-system-cl-name): New utility function for coding + systems. + (slime-net-connect, slime-make-net-buffer, + slime-open-stream-to-lisp): Use it. + (slime-net-decode-length, slime-net-encode-length): Renamed from + slime-net-read3 and slime-net-enc3. The length is now encoded as + a 6 char hex string. + + * swank.lisp (*coding-system*): New variable. + (start-server): Accept external-format as argument. + (create-server, create-swank-server, setup-server) + (serve-connection, open-dedicated-output-stream) + (create-connection): Ditto. + (defstruct connection): Add external-format slot. + (decode-message-length): New function for new length encoding. + (decode-message): Use it. + (encode-message): Use new encoding. + + * swank-cmucl.lisp (accept-connection): Accept external-format + argument. + (inspect-for-emacs): Add CMUCL specific versions for array and + vectors. + + * swank-sbcl.lisp, swank-openmcl.lisp, swank-lispworks.lisp, + swank-clisp.lisp, swank-backend.lisp, swank-allegro.lisp, + swank-abcl.lisp (accept-connection): Accept :external-format as + argument. + +2004-11-19 Matthew Danish <mrd+nospam(a)cmu.edu> + + * swank-allegro.lisp: (count-cr): New function. Convert + file-offsets to match Emacs' eol-conventions. + (find-definition-in-file): Use it. + + * slime.el (slime-insert-xrefs): Display the multi-line label much + more cleanly. + +2004-11-19 Helmut Eller <heller(a)common-lisp.net> + + * swank-sbcl.lisp (thread-status): Decode the thread-state-slot + instead of returning ???. + + * swank-allegro.lisp (swank-mop:slot-definition-documentation): + ACL 7 says documentation should have 2 args. So, pass t as second + argument. + (fspec-primary-name): Recurse until we have a symbol. + (allegro-inspect): New function. Mostly reverse engineered from + ACL's native inspector. + (inspect-for-emacs (t), inspect-for-emacs (function)): Use it. + + * swank.lisp (inspect-for-emacs array): Use row-major-aref instead + of a displaced array. I hope that does the same. + (inspect-for-emacs integer): Ignore errors in + decode-universal-time. Negative values and, in SBCL, also small + values cannot be decoded. + (list-threads): Include the thread-id. Useful for SLIME debugging. + + * slime.el (slime-list-threads, slime-thread-insert): Show the + thread-id. + (slime-thread-control-mode-map): Remove the binding for the + no-longer-existent slime-thread-goahead command. + +2004-11-18 Alexey Dejneka <adejneka(a)comail.ru> + + * swank.lisp (inspect-for-emacs): Fix bug in handling of arrays + with fill-pointers. + +2004-11-15 Helmut Eller <heller(a)common-lisp.net> + + * slime.el: The REPL commands ,quit and ,sayoonara are now + distinct. Previously Quit killed all Lisps an all buffers. The + new Quit command kills only the current Lisp. + (slime-quit-lisp): New function. + (repl-command quit): Use it. Don't delete all buffers. + (repl-command sayoonara): No longer an alias for ,quit. + (slime-connection-list-mode-map): Bind C-k to slime-quit-lisp. + (slime-communication-style): New connection variable. + (slime-use-sigint-for-interrupt): Is no longer a connection local + variable. It's derived from the new slime-communication-style. + (slime-inhibit-pipelining): New user option. + (slime-background-activities-enabled-p): New predicate to control + various background activities like autodoc and arglist fetching. + (slime-space, slime-autodoc-message-ok-p): Use it. + (slime-search-call-site): Use hints provided to search a call-site + in a defun. Useful for the show-frame-source command. + (slime-goto-source-location): Use it. + (slime-quit): Deleted, as it was broken. May come back later. + (slime-inspector-label-face, slime-inspector-value-face) + (slime-inspector-action-face, slime-reader-conditional-face): + Provide better defaults for Emacsen which don't support :inherited + faces. + + * swank-backend.lisp (emacs-connected): Don't pass the stream as + argument. make-stream-interactive is a better place for setting + buffering options. + + * swank-cmucl.lisp (emacs-connected): Install GC hooks to display + GC messages in the echo area. + (sos/misc :flush-output): There seem to be funny signal safety + issues if the dedicated output stream is not used. So, lets first + reset the buffer index before sending the buffer to the underlying + stream. + + * swank-lispworks.lisp (frame-source-location-for-emacs): Pass the + function name of the next (newer) frame as a hint to Emacs. This + way we can highlight the call site in some cases, instead of the + entire defun. + (frame-location): Renamed from function-name-location. The + argument is now a dspec, not only a name. Also include hints for + Emacs. + (lispworks-inspect): Simplified from old code. + (inspect-for-emacs): Use it for also for simple functions. + (emacs-connected, make-stream-interactive): Move the + soft-force-output stuff to make-stream-interactive. + + * swank-abcl.lisp (emacs-connected): Deleted. The default + implementation should be good enough. + + * swank-sbcl.lisp (emacs-connected): Updated for new interface. + + * swank-openmcl.lisp (emacs-connected, make-stream-interactive): + Move buffering stuff to make-stream-interactive. + + * swank.lisp (defstruct connection): Add new slot: + communication-style for convenience. + (create-connection): Initialize the new slot. + (connection-info): Send the communication-style to Emacs. + (install-fd-handler, simple-serve-requests): Sending + :use-sigint-for-interrupt is no longer necessary. + +2004-11-11 Raymond Toy <raymond.toy(a)ericsson.com> + + * slime.el (slime-activate-font-lock-magic): Add XEmacs support. + (slime-reader-conditional-face): New face. + +2004-11-10 Marco Baringer <mb(a)bese.it> + + * swank-backend.lisp (definterface): Eliminate unused variable + received-args. + (emacs-connected, make-stream-interactive, condition-references, + condition-extras, buffer-first-change): Add (declare (ignore X)) + for unused arguments in default implementations. + (inspect-for-emacs): Remove (declare (ignore)) for inexistent + variable inspection-mode. Added T qualifiers in method arguments. + + * swank-openmcl.lisp (inspect-for-emacs): Use definterface so + SLIME knows we implement this. + (arglist function): Use ccl:arglist, not ccl::arglist-from-map. + (inspect-for-emacs): Added support for inspecting the uvector + objects under lisp datums. + +2004-11-09 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (features-for-emacs): New function to avoid + keyword/string confusion. Case doesn't matter since Emacs will + downcase them anyway. + (connection-info, sync-features-to-emacs): Use it. Should fix + highlighting bug reported by Edi Weitz. + + * slime.el (slime-eval-feature-conditional): Convert AND, OR, and + NOT to lowercase keywords. + (slime-net-read3): Silly optimization: give char-after the offset + as argument to avoid save-excursion and forward-char. + +2004-11-07 Brian Downing <bdowning(a)lavos.net> + + * slime.el (slime-fuzzy-explanation): Added line to describe + flags (:boundp, :fboundp, :macro, etc), which are now reported in + the fuzzy-completion output. + (slime-fuzzy-insert-completion-choice): Added flags. + (slime-fuzzy-choices-buffer): Added flags header. + + * swank.lisp (fuzzy-completions): Changed docstring to describe + new flags in the completion results. + (convert-fuzzy-completion-result): New function to marshall the + results from the completion core into something Emacs is + expecting. Added flags. + (fuzzy-completion-set): Use the above. + (compute-completion): Removed. + (score-completion): Cleaned up a little bit. + (highlight-completion): Use destructive nstring-upcase. + +2004-11-01 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-easy-menu): Add item for + slime-update-indentation. Suggested by Lynn Quam. + (slime-severity-faceslime-show-note-counts) + (slime-most-severe, slime-choose-overlay-region): Handle + read-errors. + (slime-show-buffer-position): New function. + (slime-show-source-location): Use it. + + * swank-backend.lisp (deftype severity): Add read-errors. + + * swank-cmucl.lisp (severity-for-emacs): Special case read-errors. + (read-error-location): Add the offset to the buffer start. + + * swank.lisp (assign-index): Avoid linear search. + +2004-10-30 Helmut Eller <heller(a)common-lisp.net> + + * swank-source-path-parser.lisp (source-path-stream-position): + Bind *read-suppress* only as long as we skip over forms. The last + toplevel form in the path is read with *read-suppress* = nil + because in newer versions of CMUCL and SBCL read will return nil + if *read-suppress* is t. + +2004-10-28 Helmut Eller <heller(a)common-lisp.net> + + * swank-clisp.lisp: Ups. Undo previous change. + + * swank-clisp.lisp: Add workaround for CLISP's broken control + string parser. + + * swank-cmucl.lisp (set-step-breakpoints): Handle breakpoints at + single-return points in escaped frames better. Previously we + tried to set a breakpoint at the current position and consequently + was only hit during the next call. + (inspect-for-emacs)[function]: Call the next method only for + funcallable instances. + (profile-report, profile-reset, unprofile-all): We have to use + eval because the macro expansion depends on the value of + *timed-functions*. Reported by Chisheng Huang. + + * slime.el (slime-space): Call slime-message in the right buffer, + so that after-command hooks are added in the right buffer. + Reported by Juho Snellman. + (slime-dispatch-event): Accept stepping flag. + (sldb-setup): Don't query when entering a recursive edit. + (sldb-exit): Don't kill the buffer if we are in stepping mode. + (slime-inspector-insert-ispec): New function. + (slime-open-inspector): Use it. + (slime-inspector-operate-on-point): Simplified. + (test interactive-eval): Fix test case. + (slime-kill-all-buffers): More regexp kludges. From Bill Clementson. + + * swank-backend.lisp (activate-stepping): New function. + + * swank.lisp (*sldb-stepping-p*): New variable. Used to tell + emacs that the debugger buffer should not be closed even if we + unwind. + (debug-in-emacs): Use it. + (sldb-step): Moved to the front end. + (inspector-princ, method-specializers-for-inspect): Simplified. + (methods-by-applicability): Use a simpler algorithm. I doubt there + is much difference in practice. + (inspect-for-emacs)[symbol, function, standard-generic-function] + [standard-method]: Use less than 80 columns. + (inspector-call-nth-action): Don't accept &rest args. Was never + used. + (inspect-for-emacs) [integer]: Fix control string. Thanks to CSR + for pointing it out. + +2004-10-27 Helmut Eller <heller(a)common-lisp.net> + + * swank-sbcl.lisp (signal-compiler-condition): Actually delete one + of the reader-conditionalized forms. + +2004-10-26 Helmut Eller <heller(a)common-lisp.net> + + * cl-indent.el: Add indentation specs for some missing CL symbols. + (lisp-prefix-match-indentation): Change default to + nil to avoid confusion for people who don't care about the issue. + + * swank-sbcl.lisp (signal-compiler-condition): Remove reader + conditionals as the current code doesn't work in any SBCL before + 0.8.13 anyway. + + * swank-source-path-parser.lisp: Remove workarounds for SBCL bugs. + The bugs are fixed in the versions we support. + + * swank-cmucl.lisp (read-error-location) + (signal-compiler-condition): Handle read-errors. + (swank-compile-file): Don't load the fasl file if there was an + error. + + * swank.lisp (define-printer-variables): Handle doc strings + properly. + (*sldb-pprint-dispatch*): Initialize it with the default dispatch + table. + + * slime.el (slime-init-command): New function to send the command + to load swank. Having a separate function for the task should + make it easier to start a Lips with a preloaded swank. + (slime-maybe-start-lisp): Use it. + (slime-maybe-start-multiprocessing): Deleted. + (slime-repl-buffer): Include the name of the implementation. + (slime-set-default-directory) + (slime-sync-package-and-default-directory): Translate filenames. + +2004-10-25 Marco Baringer <mb(a)bese.it> + + * swank.lisp (inspect-for-emacs array): Properly deal with arrays + without fill pointers. + (inspect-for-emacs function): Show function-lambda-expression + when available. + + * swank-openmcl.lisp (specializer-name): New function. + (who-specializes): Use it. + (maybe-method-location): Use it. + (function-source-location): Use it. + + * swank-cmucl.lisp (inspect-for-emacs function): Use next + method's values and simply add cmucl specific details. + + * slime.el (slime-repl-defparameter): Change default value to "*". + +2004-10-25 Thomas Schilling <tjs_ng(a)yahoo.de> + + * swank-allegro.lisp (inspect-for-emacs): Use + excl::external-fn_symdef to get the function documentation. + + * swank.lisp (inspect-for-emacs): Order generic function's methods + and show abbreviated docs for methods. + (abbrev-doc): New function. + (methods-by-applicability): New function. + (*gf-method-getter*): New variable. + +2004-10-19 Luke Gorrie <luke(a)synap.se> + + * slime.el (slime-show-source-location): Call `push-mark' to push + the source position onto the global mark ring. + +2004-10-19 Helmut Eller <heller(a)common-lisp.net> + + * swank.lisp (define-printer-variables): NIL is not a valid + docstring. Reported by Alain Picard. + (printer-variables sldb-print): Include print-gensym, + pprint-dispatch, base, radix, array, and lines. + +2004-10-17 Luke Gorrie <luke(a)synap.se> + + * slime.el (slime-message): Use slime-typeout-frame if available. + +2004-10-17 Helmut Eller <heller(a)common-lisp.net> + + * cl-indent.el: Our local copy. Should eventually be merged the + file with in the main distribution. + + * slime.el: (slime-find-buffer-package-function): New variable to + allow customization for unusal syntax. + (slime-maybe-rearrange-inferior-lisp): Removed unused function. + (slime-set-inferior-process): Non-macro version to make + byte-compiler happy. Reported by Raymond Wiker. + (slime-maybe-start-lisp): Use it. + (slime-sync-package-and-default-directory): Synch the + default-directory in the REPL buffer too. + (slime-goto-connection): Close the connection list window. + Suggested by Andras Simon. + (slime-repl-clear-buffer): Place point after the prompt. + (selector-method ?i): Use slime-process to switch to the right + buffer. + (slime-background-message): Do nothing if the minibuffer is + active. + (slime-indent-and-complete-symbol): Don't indent if we at the same + line as the prompt. + + * swank.lisp (*sldb-pprint-frames*): Renamed to + *sldb-print-pretty*. + (*sldb-print-level*, *sldb-print-length*, *sldb-print-circle*) + (*sldb-print-readbly): Group of new variables to customize + printing in the debugger. The default values should be safe. + (define-printer-variables, with-printer-settings): New macros to + make defining and binding groups of printer variables easier. + (inspect-for-emacs-list): Fix bug with circular lists and only + shows the first 40 elements. + (inspect-for-emacs): Various cleanups. + (all-qualified-readnames): Removed. It was not needed because + common-lisp-indent-function strips of any package prefix and + downcases the symbol anyway. + (printer-variables sldb-print): Ooops. Better use sldb-print as prefix + than sldb alone. *sldb-level* was already defined. + + * swank-cmucl.lisp (inspect-for-emacs (code-component)): + Disassemble the memory region if there's not enough debug info. + +2004-10-17 Jan Rychter <jan(a)rychter.com> + + * swank-cmucl.lisp (return-from-frame): Add it. + +2004-10-11 Thomas F. Burdick <tfb(a)OCF.Berkeley.EDU> + + * swank-sbcl.lisp (function-definitions): Find compiler macros, too. + (find-defintions, compiler-definitions) + (optimizer-definitions, transform-definitions): Add compiler + transformers and optimizers to the list of definitions. + +2004-10-07 Peter Seibel <peter(a)javamonkey.com> + + * swank.lisp (spawn-threads-for-connection): Bind *debugger-hook* + instead of SETF'ing it. + +2004-10-06 Luke Gorrie <luke(a)synap.se> + + * swank.lisp (update-indentation/delta-for-emacs): Configure Emacs + indentation settings not just for the symbol name but for all + package-qualified forms of it as well. + + * doc/slime.texi (Credits): Updated the credits list to include + more Lisp implementors who're also SLIME hackers. + +2004-10-05 Luke Gorrie <luke(a)synap.se> + + * swank.lisp (arglist-for-echo-area): Handle errors and return a + message. + (parse-symbol): Recognise an empty package name as the KEYWORD + package. + +2004-10-03 Reini Urban <rurban(a)x-ray.at> + + * swank-clisp.lisp (getpid)[win32]: Use + win32:|GetCurrentProcessId|. + +2004-10-03 Helmut Eller <heller(a)common-lisp.net> + + * slime.el: Reduce dependency on inf-lisp internals. Make it + possible to start the inferior lisp in a buffer different from + "*inferior-lisp*". + (slime): Parse the command argument explicitly and don't rely on + `inferior-lisp'. Don't close all connections, but only the one + for the inferior lisp buffer we are using. + (slime-maybe-start-lisp): Take the command and buffer as argument. + Decide here whether we should start start a new processwe or just + disconnect and reconnect . + (slime-start-lisp): Load verbosely. + (slime-inferior-lisp): New function. Replaces call to + `inferior-lisp'. + (slime-inferior-connect, slime-start-swank-server): Take the + inferior process as argument + (slime-read-port-and-connect): Set the slime-inferior-process + variable in the new connection. + (slime-inferior-process): New connection local variable. + (slime-process): Use it. + (slime-restart-inferior-lisp): Don't use inferior lisp stuff. + (slime-switch-to-output-buffer): Process interactive arguments + properly. + + * swank-loader.lisp (compile-files-if-needed-serially): Load + verbosely. + +2004-10-01 Helmut Eller <heller(a)common-lisp.net> + + * swank-allegro.lisp (find-fspec-location): excl:source-file can + return stuff like (:operator ...); try to handle it. + + * swank-cmucl.lisp (code-component-entry-points): Only include + entry points with "valid" functions names. This excludes internal + lambdas which have usually a string as name, like "defun foo". + + * swank.lisp (parse-symbol): Don't use the reader to avoid + interning unknown symbols. The downside is that we no longer + handle escaped |symbols| correctly. + + * slime.el (slime-set-connection-info): Hide the *inferior-lisp* + buffer after we know Lisp's pid. Print the words of encouragement + here, when all the other asynchronous initialization is completed. + (slime-find-buffer-package): We need to preserve the case for + things like (:in-package "foo"), so return "\"foo\"". + +2004-09-27 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-process): New function intended to replace all + those references to the *inferior-lisp* buffer. + (slime-maybe-start-lisp): Split it up. + (slime-start-lisp): New function. + (slime-restart-inferior-lisp): Use the command from the existing + process to start the new process. + +2004-09-27 Christian Lynbech <christian(a)defun.dk> + + * slime.el (define-slime-dialect): New macro to make starting + Lisps with different command line options easier. + +2004-09-27 Rui Patroc�nio <rui.patrocinio(a)netvisao.pt> + + * swank.lisp (mop, mop-helper): Support functions for the class + browser. + + * slime.el (slime-browse-classes, slime-browse-xrefs): New + commands to browse class hierarchies and xref graphs in a tree + widget. + + * tree-widget.el: New file. Only needed for older Emacsen. + +2004-09-23 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (slime-start-and-load): Take arguments so that the + function can be called non-interactively. Only start SLIME is if + it is not running. + (slime-recompile-bytecode): Don't warn about uses of cl-functions. + (slime-reset): Kill all sldb buffers. + (slime-goto-location-position): Fix syntax for Emacs 20. + (sldb-mode-map): Add C-c C-d bindings. + (slime-open-inspector): Insert the type in the second line so that + we can make longer titles, e.g we should include the princed + version of the inspected object. + + * swank-backend.lisp (frame-package, label-value-line) + (label-value-line*): New functions. + + * swank.lisp (frame-locals-for-emacs): Bind *print-pretty* to + *sldb-pprint-frames* to get more compact lines and bind *package* + to frame-package to get shorter labels for variables. + (format-values-for-echo-area): Include the hex and octal + representation for integers. + (apply-macro-expander, disassemble-symbol): Use the buffer-package + for reading. + (inspector-content-for-emacs): Use print-part-to-string so that we + see cycles in the data structure. + (inspect-for-emacs): Minor beautifications. + (load-file-set-package): New function. + + * swank-cmucl.lisp (frame-package): Implemented. + (inspect-for-emacs): Only include stuff that is actually stored in + the object itself (see objdef.lisp for exact object layout). + Include the disassembly for functions and code components. + +2004-09-19 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-gray.lisp (stream-read-char): Treat empty strings as + end-of-file. + + * swank-cmucl.lisp (sis/in): Treat empty strings as end-of-file. + (map-allocated-code-components): Inhibit efficiency notes. + (arglist)[symbol] Delete unreachable code. + (sldb-break-on-return, sldb-break-at-start): Implement it + (sldb-step): Some cleanups. + + * swank.lisp (thread-for-evaluation): Restart the listener thread + if it was dead for some reason. + (debugger-condition-for-emacs): Include "extra" stuff. Currenlty + only used to pop up the source buffer at breakpoints. + (sldb-break): New function. + (interrupt-worker-thread): Interrupt the repl thread if there is + no other active thread. + + * swank-backend.lisp (import-swank-mop-symbols): New + function. Useful if the implementation has most of the mop symbols + in the same package. + (sldb-break-on-return, sldb-break-at-start, condition-extras): New + functions. + + * slime.el (sldb-break-on-return, sldb-break): New commands. + (slime-repl-return-string): Allow empty strings. That's our way + to send end-of-file. + (sldb-insert-condition): Add "extra" slot for random thing that + don't fit nicely somewhere else. + (sldb-dispatch-extras): New function. + (sldb-show-frame-source): New non-interactive version of + sldb-show-source. + (sldb-show-source): Use it. + (slime-beginning-of-symbol, slime-end-of-symbol): New functions + which don't include the character after a hash '#'. + (slime-symbol-name-at-point): Use them. + (slime-symbol-start-pos, slime-symbol-end-pos): Ditto. + +2004-09-17 Marco Baringer <mb(a)bese.it> + + * swank.lisp: Don't print "Documentation:" if none is available; + add support for classes specializer-direct-methods; deal with + eql-specializers in methods. + (inspector-princ): New function. + (method-specializers-for-inspect): New function. + (method-for-inspect-value): New function. + (inspect-for-emacs): Use inspector-princ instead of + princ-to-string. + + * swank-backend.lisp (swank-mop): Require eql-specializer, + eql-specializer-object and specializer-direct-methods in swank-mop + package. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-openmcl.lisp, swank-sbcl.lisp (swank-mop): Export + eql-specializer, eql-specializer-object and + specializer-direct-methods from swank-mop. + + * swank-cmucl.lisp (inspect-for-emacs): Thinko fix. + + * swank-lispworks.lisp (swank-mop): Export + specializer-direct-methods. + (eql-specializer): Implement. + (eql-specializer-object): Implement. + + * swank-sbcl.lisp (inspect-for-emacs): Fix broken ignore + declaration. + + * doc/slime.texi: Update inspector documentation. + +2004-09-16 Marco Baringer <mb(a)bese.it> + + * swank-clisp.lisp (swank-mop, inspect-for-emacs): Only define the + CLOS parts of the inspector if the underlying lisp provides the + required functionality. If not enough MOP is present to implement + the inspector then we define some very simple replacement methods. + +2004-09-16 Marco Baringer <mb(a)bese.it> + + * swank-clisp.lisp (swank-mop): Implement the MOP compatability + package. + (inspect-for-emacs): Update for new inspection API. + +2004-09-15 Alan Ruttenberg <alanr-l(a)mumble.net> + * swank-openmcl: typo in who-references. Fix frame-var-value + +2004-09-15 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-inspector-label-face, + slime-inspector-value-face, slime-inspector-action-face, + slime-inspector-type-face): These faces now inherit from similar + font-lock-<whatever> faces. + (slime-open-inspector): Use slime-inspector-value-face for values. + + * swank.lisp (inspect-for-emacs): Add function and compiler-macro + documentation when inspecting symbols. View the truename of + logical pathnames where they exist. Fix typos in package + inspector (fix by Torsten Poulin <torsten(a)diku.dk>). + + * swank-sbcl.lisp, swank-cmucl.lisp (inspect-for-emacs): Insert + function object's documentation when it's available. + +2004-09-15 Eduardo Mu�oz <emufer(a)terra.es> + + * .cvsignore: Added *.elc + + * hyperspec.el: Fixed syntax error. + +2004-09-15 Alan Caulkins <fatman(a)maxint.net> + + * swank.lisp (cleanp-connection-threads): Kill all Swank threads + for a connection when it terminates. + +2004-09-14 Thomas Schilling <tjs_ng(a)yahoo.de> + + * swank-allegro.lisp (inspect-for-emacs): Fixes to previous patch. + +2004-09-14 Marco Baringer <mb(a)bese.it> + + * swank-backend.lisp (inspector, make-default-inspector): Add an + INSPECTOR object argument to the inspector protocol. This allows + implementations to provide more information regarding cretain + objects which can't be, or simply aren't, inspected using the + generic inspector implementation. also export inspect-for-emacs + and related symbols from the backend package. + (make-default-inspector): New function. + + * swank.lisp (inspected-parts): Rename to inspect-for-emacs and + add an inspector argument. Move inspect-for-emacs to + swank-backend.lisp, leave only the default implementations. + + * swank-openml.lisp, swank-sbcl.lisp, swank-allegro.lisp, + swank-cmucl.lisp, swank-lispworks.lisp (inspected-parts): Rename + and change argument list. Many of the inspected-parts methods were + being clobbered by the inspected-parts in swank.lisp, now that + they're being used the return values have been updated for the new + inspect-for-emacs API. + +2004-09-14 Thomas Schilling <tjs_ng(a)yahoo.de> + + * swank-allegro.lisp (inspected-parts): Implement inspector for + structs. + +2004-09-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp (intern-catch-tag): New function. + (read-user-input-from-emacs, take-input): Use it. + +2004-09-13 John Paul Wallington <jpw(a)gnu.org> + + * swank.lisp (define-special): Make the doc-type `variable' + rather than `symbol'. Don't quote `doc'. Doc fix. + +2004-09-09 Martin Simmons <martin(a)xanalys.com> + + * swank-lispworks.lisp: Set up the swank-mop package. Implement + swank-mop:slot-definition-documentation and function-name. + +2004-09-13 Marco Baringer <mb(a)bese.it> + + * swank.lisp (inspected-parts): Added inspectors for pathnames, + logical pathnames, standard-objects and numbers (float, ratio, + integer and complex). + + * swank-backend.lisp: Define import-to-swank-mop. + + * swank-openmcl.lisp, swank-sbcl.lisp, swank-allegro.lisp: Don't + define the import-to-swank-mop function (now defined in + swank-backend.lisp). + + * swank-cmucl.lisp (swank-mop, function-name): Implement backend + for inspector. + (arglist): Add support for extracting arglists from function + objects. + (create-socket): Don't specify the host on PPC. + +2004-09-13 Alan Ruttenberg <alanr-l(a)mumble.net> + + * slime.el slime-goto-location-position: New location specifiers: + (:method name specializers . qualifiers) all are strings. Looks + for defxxx name then the qualifiers as words, in order then the + specializers as words, in order (except for "T", which is + optional). Pass the symbols names for specializers and qualifiers + (no packages). Used by openmcl but might be useful for others + (:text-anchored <position fixnum> <string> <delta fixnum>) + Got to position, then search for string, then move delta. To + support upcoming source recording for openmcl debugging. + + * swank-openmcl multiple changes: - fix support for *sldb-top* + (formerly *swank-debugger-stack-frame*) Was not thread safe. Now + (application-error), and (interrupt-thread) records the error + pointer in a table associated with thread and map-backtrace picks + up the appropriate pointer. *process-to-stack-top*, + (grab-stack-top), (record-stack-top). + + - Other adjustments for changes to multiprocessing: remove + (force-break-in-listener) no longer necessary since we use + process-interrupt instead of ccl::*interactive-abort-process* + Adjust break-in-sldb to do so for swank repl connections + (abstraction breaking reference to swank::*connections*, but + nicely via intern) + + - changes to (find-definitions) (function-source-location), + addition of (maybe-method-location) (remove-filename-quoting). To support + editing definitions of methods. To fix bug with pathnames with + quoted characters (like "\\.swank.lisp"). To remove bogus source + recording of l1-boot-3 in functions that didn't have a source file + noted. + + - Implementation of xref functions: (xref-locations) uses xref + implementation added to openmcl recently. Note that you have to + (ccl::start-xref) for it to work for other than who-calls, and + that xref information is not currently persisted in fasl files (I + will release a patch for this soon) Backend functions (who-binds) + (who-macroexpands) (who-references) (who-sets) + (who-calls) (list-callees) (who-specializes) + + - Lifted profile backend functions from swank-clisp which use + "metering.lisp" + + - (openmcl-set-debug-switches) turns on the various variables I. + know about that have the lisp record extra debugging + information(including starting xref). I suggest you call + it. Should it be called by default? + + - (frame-arguments) use builtin ccl::frame-supplied-args since the + current version was sometimes missing the first argument to the + function. (I think this was when it was passed by register. If you + don't want to lose it in the frame locals in backtrace, call + (openmcl-set-debug-switches) specifically, set + ccl::*ppc2-compiler-register-save-label* to t + + - implement frame-var-value backend + + * metering.lisp: Minor changes to #+ #- to recognize openmcl + + * swank-loader.lisp: Load "metering.lisp" + +2004-09-13 Marco Baringer <mb(a)bese.it> + + * swank.lisp (inspected-parts): Deal with unfinalized classes in + standard-class inspector. (Patch from Thomas Schilling) + +2004-09-13 Marco Baringer <mb(a)bese.it> + + * swank.lisp: New inspector protocol. The lisp side now returns a + specially formated list of "things" to format which are then + passed to emacs and rendered in the inspector buffer. Things can + be either text, recursivly inspectable values, or functions to + call. + (inspected-parts): Redefine for new inspector protocol. + (*inspectee-parts*): Redefine as array. + (*inspectee-actions*): New array, similar to *inspectee-parts*. + (reset-inspector): Update for new implementation of + *inspectee-parts* and new variable *inspectee-actions*. + (inspector-contents-for-emacs): New function. + (inspect-object): Update for new inspector protocol. + (inspector-nth-part): Update for new *inspectee-parts* + implementation. + (inspector-call-nth-action): New function. + + * slime.el (slime-inspector-action-face): New face. + (slime-open-inspector): Adapt to new inspector protocol. + (slime-inspector-operate-on-point): New function, subsumes + slime-inspector-inspect-object-at-point. + (slime-inspector-next-inspectable-object): Skip to next object, + not just end of current object; wrap around buffer. + (slime-inspector-mode-map): change bindings of [return] and "\C-m" + + * swank-bacend.lisp (swank-mop): New package. Simply defines all + the MOP related symbols we need from an implementation. + (arglist): Update doc string. Provide default implementation. + (function-name): New backend function. + + * swank-allegro.lisp (swank-mop, slot-definition-documentation): + Implement. (Patch from Thomas Schilling) + + * swank-sbcl.lisp (swank-mop, slot-definition-documentation, + function-name): Implement. + + * swank-openmcl.lisp (swank-mop, function-name): Implement. + (arglist): Implement for function objects. + +2004-09-12 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp (compile-file-for-emacs): Use with-buffer-syntax so + that SBCL source files can be compiled. From Christophe Rhodes. + +2004-09-09 Martin Simmons <martin(a)xanalys.com> + + * swank-loader.lisp (make-swank-pathname): Preserve the host + component (important for LispWorks on Windows). + +2004-09-08 Martin Simmons <martin(a)xanalys.com> + + * swank-lispworks.lisp: Implement call-with-compilation-hooks. + +2004-09-03 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * NEWS: Summarize changes since August. + + * slime.el: Add some docstrings. + + * mkdist.sh: Add PROBLEMS file. We're no longer alpha. + + * swank.lisp: Remove debugging code in comment. + + * swank-sbcl.lisp: Delete dead code. + + * swank-lispworks.lisp (defimplementation): define-dspec-alias + seems to more apropriate than define-form-parser. + + * swank-cmucl.lisp (print-frame): Catch errors during printing. + + * README: Fix typo. + +2004-09-02 Wolfgang Mederle <wolfgang.mederle(a)stud.uni-muenchen.de> + + * swank-loader.lisp (*lisp-name*): Replace / with - in CMUCL + version strings. + +2004-09-01 John Paul Wallington <jpw(a)gnu.org> + + * slime.el (slime-oneliner): Don't use free variable. + (slime-recenter-window, slime-set-connection-info) + (slime-pprint-event, slime-compiler-notes-quit) + (slime-apropos-summary): Likewise. + (slime-connect): Tidy up handshake `message' call. + +2004-09-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-repl-push-directory): Fix interactive spec. + (sldb-reference-properties): Take a the reference object as + argument instead of its parts. Fix callers accordingly. + (slime-fuzzy-choices-buffer): Remove assignment to unused variable + slime-fuzzy-target-mtime. + (slime-ed): Replace call to new-frame with make-frame. + (sldb-find-buffer): Cleanup. + (sldb-highlight-sexp): Fix regexp. It's now almost a full line. + + * swank.lisp (completion-set, tokenize-symbol-designator) + (tokenize-completion, fuzzy-completion-set) + (briefly-describe-symbol-for-emacs): Remove simple-base-string + declarations. + +2004-08-30 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * PROBLEMS: We require SBCL 0.8.13. 0.8.12 is no longer + supported. + + * swank-allegro.lisp (find-fspec-location): Catch errors in + excl:source-file. + + * swank.lisp (send-to-socket-io): Add some ignore declarations. + + * slime.el (sldb-fetch-all-frames, sldb-end-of-backtrace) + (sldb-beginning-of-backtrace): New commands. + (slime-search-suppressed-forms): Change the start regexp so that + reader conditionals in single line comments, like "; #+foo", are + ignored. + +2004-08-27 Peter Seibel <peter(a)javamonkey.com> + + * swank-backend.lisp (swank-compile-string): Add directory + argument which is used by Allegro backend to improve source + recording for definitions compiled with C-c C-c. + +2004-08-23 John Paul Wallington <jpw(a)gnu.org> + + * slime.el (slime-pretty-package-name): Fix last cond clause. + +2004-08-21 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp (*global-debugger*): New configurable to globally + install swank-debugger-hook as *debugger-hook*. True by default. + +2004-08-19 Luke Gorrie <luke(a)bluetail.com> + + * doc/slime.texi: C-c C-c C-a, C-c C-u C-e. + Thanks Barry Fishman for reporting incorrect indexing. + +2004-08-18 Matthew Danish <mrd+nospam(a)cmu.edu> + + * swank-allegro.lisp (swank-compile-string): Use #\; instead of + #\: to separate the position from the buffer-name. This avoids + troubles on Windows. + +2004-08-16 Luke Gorrie <luke(a)bluetail.com> + + * doc/slime.texi: Random updates. + + * slime.el (slime-space): Use slime-message instead of + slime-background-message. This displays multi-line arglists. + (sldb-mode-map): Bind 'C' to sldb-inspect-condition. + +2004-08-14 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-find-buffer-package): Use "%s", not "%S", to + avoid ugly escape characters, if the package name contains dots. + +2004-08-13 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (sldb-eval-in-frame): Print result to the REPL when a + prefix argument is given. + Added pull-down menus for SLDB and the REPL. + + * swank-source-path-parser.lisp: Removed caching of readtables and + the source-map hashtable. Fresh creation is ultra-cheap (<1ms). + The caching didn't handle modifications to readtables and + generally made me feel uneasy while tracking down an obscure bug + in a reader macro. + The cached source-map hashtable also wasn't thread-safe (ho hum). + +2004-08-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-merge-notes, slime-tree-for-note): Use the short + note message for annotation in the source buffer and the long + message in the tree widget. Used to be the other way around. + (sldb-insert-frames): Set the `start-open' property for XEmacs. + Without `start-open', the `point-entered' property is inherited + when we insert something before the "--more--" marker. Reported + by Sundar Narasimhan. + + * swank.lisp (variable-desc-for-echo-area): Bind some printer + variables to limit the length of the output. + +2004-08-05 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-setup): Added typeout-frame keyword argument. + (slime-thread-attach): Fixed misnamed function call. + +2004-08-04 Luke Gorrie <luke(a)bluetail.com> + + * swank-allegro.lisp (find-fspec-location): Fixed to work for more + types of definition than just functions. So M-. now works for e.g. + classes in Allegro. From Matthew Danish. + (find-fspec-location): Include the type of the definition in the + designator sent to Emacs. From Matthew Danish. + +2004-08-04 Martin Simmons <martin(a)xanalys.com> + + * swank-lispworks.lisp (frame-actual-args): Correct syntax for + handler-case. + +2004-08-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: (slime-mode-map, slime-repl-mode-map) + (slime-repl-read-mode-map): Remove the binding for C-c C-g. C-c + C-b is now the default interrupt key. + (slime-list-repl-short-cuts): Don't trash the shortcut-table: copy + it before sorting. (Thanks to Mark Simpson.) + +2004-08-02 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-connect): Shorten the welcome message by leaving + out the port number (which is displayed in the REPL anyway). This + avoids line-wrapping some messages of encouragement. + + * swank.lisp (with-buffer-syntax): Don't bind *readtable* to + *buffer-readtable* if they are already EQ. When we shadow this + binding the user can't assign *readtable* from the REPL so it's + best avoided when possible. + + * swank-allegro.lisp: Removed fwrapper-based code for inheriting + "swankiness" to newly spawned threads. This was fighting the + system and not the right thing. + + * slime.el (slime-choose-overlay-region): Tweaked the + multiline-annotation-avoidance code to work with forms not + starting with an open-paren, e.g. `(..) or #'(..). + (slime-update-modeline-package): New configurable. Non-nil (the + default) means update the Lisp package in the modeline using an + idle timer. + (slime-repl-send-input): Make the `slime-repl-old-input' property + cover the whole input (including newline) so that pressing RET on + the end of an input line works. + Use a unique integer as the value of this property to distinguish + adjacent inputs. + (slime-current-package): Deal with narrowing. + +2004-08-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-allegro.lisp (swank-compile-string): Use a temporary file + and set excl::*source-pathname* manually. This way we can find + the source buffer of functions compiled with C-c C-c. + (call-with-temp-file, compile-from-temp-file): New functions. + (list-callers, function-callers, in-constants-p) + (map-function-constants): Implements list callers by groveling + through the constants pools of named functions. + + * swank-lispworks.lisp: Minor refactoring. + +2004-07-30 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-connection): Say "No default connection + selected" if there are open connections but no default connection. + (slime-tree-indent-item): Point wasn't updated correctly if the + last line was empty. Use insert-before-markers instead of insert + to do it properly. + (slime-draw-connection-list): Don't break if there is no default + connection. + + * swank-cmucl.lisp (call-with-debugging-environment): Only handle + DI::UNHANDLED-CONDITION not all DI:DEBUG-CONDITIONs. + + * swank-backend.lisp (sldb-condition): Show the original condition + in the message. + +2004-07-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-eval-feature-conditional): Treat uppercase + operators NOT, AND, OR correctly. + (sldb-find-buffer): Remove killed buffers. + (sldb-quit): Raise an error if the RPC returns. + (slime-expected-failures): Delete unused function. + (complete-symbol): Test completion of + swank::compile-file. LispWorks has extra completions for + cl::compile-file. + (arglist): Test arglist of method cl:class-name. Add enough + regexpery to pass the test in most implementations. + + * swank-sbcl.lisp (list-callers, list-callees): Implemented. + +2004-07-26 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-first-change-hook): Add `save-match-data' to + avoid breaking e.g. query-replace. Also added `save-excursion' + just to be safe. + + * README: s/setup-slime/slime-setup/ in the .emacs snippet. + +2004-07-23 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-set-state): Show the message in the modeline in + the case where we aren't connected. Otherwise the "not connected" + status is ignored. + (slime-net-sentinel): Close the connection before changing the + status message. The old behaviour of this combined with the old + behaviour of `slime-set-state' could generally cause spurious + errors after a connection was closed. + +2004-07-22 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp (carefully-find-package): Return *BUFFER-PACKAGE* if + no other package can be found. This is reverting a previous change + that broke completion in buffers with no known package. + + * slime.el (slime-maybe-start-lisp): Check that *inferior-lisp* + exists /and/ has a running process. Fixes a startup problem if + your inferior-lisp has died and you want to restart SLIME. + +2004-07-21 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-sync-package-and-default-directory): Sync + `default-directory' in the REPL buffer too. + (slime-set-state): Convenience function for setting a connection's + state-name and updating the modeline if appropriate. This function + is called in the right places. + (slime-to-lisp-filename): Use `expand-file-name'. + +2004-07-20 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-repl-update-banner): Restore old behaviour of + using an asynchronous evaluation to setup the REPL. This works + around a problem I'd reintroduced where the first REPL command + uses the wrong keymap. + +2004-07-20 Andreas Fuchs <asf(a)boinkor.net> + + * swank-sbcl.lisp (call-with-compilation-hooks): Trap and report + errors that cause compilation to fail, e.g. read errors. + +2004-07-19 Luke Gorrie <luke(a)bluetail.com> + + * HACKING: Updated. Some notes about Emacs features. + + * slime.el: More major refactoring. + Restructured and documented the networking and protocol code. + (slime-rex-continuations): Now connection-local. + +2004-07-18 Luke Gorrie <luke(a)bluetail.com> + + * slime.el: Major refactoring. + Mostly resectioning and reordering definitions to try and improve + readability. + (slime-get-temp-buffer-create): New utility function to popup a + temporary buffer that automatically has a binding on `q' to + intelligently restore window configuration. Handy, but currently + not applicable to all of our temporary buffers. + (slime-with-chosen-connection): Removed this macro. Consequently + the compilation commands no longer prompt for which connection to + use when given a prefix argument. `slime-switch-to-output-buffer' + still works like that, but for other cases I think the + connection-list buffer is sufficient. + (slime-eval-async): New arglist: (form &optional cont pkg). If the + continuation is unspecified then the evaluation result is ignored, + and if the package is unspecified then (slime-buffer-package) is + used. + (slime-eval): Package arg now defaults to (slime-buffer-package). + (slime-current-package): New name for (slime-buffer-package). No + more caching: returns the buffer-local `slime-buffer-package' if + set, otherwise searches for an `in-package' form. + A consequence of non-caching is that the package name doesn't + appear in the modeline anymore. The simplification is worthwhile + in my opinion. + +2004-07-17 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-autodoc): If there is a global variable name at + point then show its value. + (slime-autodoc-cache-type): Cache type 'full is no longer + supported. + (slime-background-message): Truncate messages to fit on a single + echo area line. + (slime-repl-update-banner-p, slime-dont-prompt) + (slime-swank-connection-retries): Removed these unused or unuseful + configuration variables. + Rearranged organised "customize" groups. + + * swank.lisp (variable-desc-for-echo-area): New function. + (arglist-for-echo-area): Return nil if symbol can't be found. + (close-connection): Close connection before printing error + message. This avoids it getting lost in closed I/O redirection. + + * README, doc/slime.texi: Updated setup instructions. + +2004-07-16 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-conservative-indentation): New variable. When + true (the default) don't auto-learn indentation of def* and with-* + macros. Set to nil if you want to learn them. + (slime-handle-indentation-update): Use it. + + * swank.lisp (known-to-emacs-p): Removed filtering of def* and + with-*. Now handled by Emacs. + + * slime.el (slime-interactive-eval): Changed display of results. + By default the result goes to `slime-message', which leads either + to echo area, temporary buffer, or typeout frame. + With a prefix argument the result is printed to the REPL. + This goes for all commands based on slime-interactive-eval, e.g. + `C-x C-e' and `C-c M-:'. + +2004-07-16 Peter Seibel <peter(a)javamonkey.com> + + * slime.el (package-updating): Fixing this and other tests I broke + with my change to how emacs keeps track of the package prompt + string. + (arglist): Fix an test failure under Allegro due to a slight + difference in the way EXCL:ARGLIST returns arglist (no default + values of &optional parameters) + +2004-07-16 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp (print-connection): print-function for connection + objects. Dumping the indentation-cache was damned ugly with + non-truncated lines (e.g. bug reports on slime-devel). + + * slime.el (slime-setup): New function for installing a + lisp-mode-hook. You can call this from ~/.emacs to setup SLIME. + Takes a `autodoc' keyword argument to enable + slime-autodoc-mode. We can add more keywords in future. + (slime-keys): Moved `slime-reindent-defun' from C-M-q to + C-cM-q. This avoids overriding the standard binding of C-M-q to + index-sexp. + (slime-typeout-frame-properties): Removed some properties: + `name', because it interacts badly with X properties, `left' and + `top' because they don't put the frame anywhere terribly + convenient, and (width . 40) because it makes the frame narrower + than the usual word-wrapping width. + +2004-07-14 Peter Seibel <peter(a)javamonkey.com> + + * slime.el (slime-lisp-package-prompt-string): Separate SLIME's + notion of package into two parts, an actual package name and the + name used in the prompt since the latter isn't necessarily an + actual package nickname any more. + +2004-07-13 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-restart-inferior-lisp): Renamed shortcut to + "restart-inferior-lisp" from "restart-lisp". The name better + suggests what it does: kill *inferior-lisp* and rerun SLIME. + +2004-07-13 Eric Blood <eblood(a)winkywooster.org> + + (slime-inspector-next-inspectable-object): New inspector command + to goto the next inspectable object (slot). Bound to TAB. + +2004-07-13 Christophe Rhodes <csr21(a)cam.ac.uk> + + * slime.el: add support for actionable references in the + *slime-compiler-notes* buffer. + (slime-merge-notes): merge references if applicable. + (slime-compiler-notes-mode-map): use new functions defaulting to + show-details, but overrideable by text properties. + (slime-tree-default-printer): destroy generality by assuming a + tree of conditions, and insert references if applicable. + (sldb-format-reference-source): add :amop + + * swank-sbcl.lisp (signal-compiler-condition, + brief-compiler-message-for-emacs, + long-compiler-message-for-emacs): handle references in compiler + conditions. + + * swank.lisp (make-compiler-note): propagate references. + + * swank-backend.lisp (compiler-condition): add references slot. + +2004-07-12 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-easy-menu): Added "Apropos all" menu item. + (slime-restart-lisp): Added `restart-lisp' shortcut. Doesn't do + the right thing if you have multiple Lisps up. + + * swank.lisp: Added some docstrings. + Rearranged completion code and somewhat SLDB trying to layout + functions above their subfunctions in a tree-like way. + (slime-protocol-error): Renamed from slime-read-error. + (carefully-find-package): Now returns NIL if package can't be + determined, rather than *BUFFER-PACKAGE*. Correct? I didn't see + why it should return *BUFFER-PACKAGE*. + (xref): Find symbol in *BUFFER-PACKAGE*. + +2004-07-09 Peter Seibel <peter(a)javamonkey.com> + + * swank.lisp (package-string-for-prompt): Change the way package + name in prompt is computed. N.B. after this change the name + displayed will not necsarily be either an actual name or nickname + of the package: if the name contains dots by default the prompt + will only display the last element, i.e. COM.GIGAMONKEYS.SPAM will + be shown as SPAM. This change also makes CL-USER the canonical + name for COMMON-LISP-USER even in implementations that provide a + shorter nickname such as USER. + +2004-07-09 Christophe Rhodes <csr21(a)cam.ac.uk> + + * slime.el (sldb-lookup-reference): substitute hyphens for spaces + in the url. + +2004-07-07 Thomas Schilling <tjs_ng(a)yahoo.de> + + * swank.lisp (arglist-for-insertion): Changed formatting to use + arglist-to-string. That results in proper cases for + slime-insert-arglist. + +2004-07-07 Luke Gorrie <luke(a)bluetail.com> + + * swank-loader.lisp (*lisp-name*): Include the version number in + ACL. + + * slime.el (slime-alistify): Preserve order. This keeps the + *compiler-notes* right. Pointed out by Christophe Rhodes. + (slime-repl-update-banner-p): Renamed from slime-reply-.. + (slime-changelog-date): Reintroduced for informational purposes. + (slime-repl-update-banner): Show ChangeLog date in the animation. + (slime-space): Do arglist lookup before inserting the + space. Otherwise we get a funky race condition: entering the space + may trigger `first-change-hook', which would send an async + notification to Lisp, which would put us in the 'busy' state and + thus we wouldn't lookup the arglist! Detective work by Edi Weitz. + (sldb-prune-initial-frames): More regexp fudgery :-(. + (read-directory-name): Use `file-name-as-directory' to ensure we + have the trailing / on the directory name. + (byte-compile-warnings): Bye-compile slime-alistify. Its inputs + can be pretty big. + +2004-07-04 Luke Gorrie <luke(a)bluetail.com> + + * slime.el, swank-backend.lisp, swank.lisp: Added a new backend + function `buffer-first-change' which is called via Emacs's + `first-change-hook' in slime-mode buffers. This gives Lisp a + chance to do something with source files before you change them on + disk. + + * swank-cmucl.lisp (buffer-first-change): Suck the source file + into the cache unless already present. This is for M-. to increase + the chances of our having a copy of the sources corresponding with + the loaded code. Should help with the case where a user edits and + saves a file (without recompiling it) and then M-.'s for one of + its definitions. + + * swank-allegro.lisp (make-process/inherit): Changed reader + conditionals to use fwrappers for #+(version>= 6). + + * swank-backend.lisp (make-stream-interactive): This backend + function is called with each stream that will be used for + user-interaction, i.e. the redirected stdio streams. Can be used + to setup special output-flushing or similar. + + * swank.lisp (open-streams): Call make-stream-interactive on the + redirected io streams. + + * swank-allegro.lisp (make-stream-interactive): Set + interactive-stream-p slot on the stream to make it auto-flush. + (*swank-thread*, *inherited-bindings*): New variables. + (spawn): Bind *swank-thread* to T. + (make-process/inherit): Fwrapper (advice) for + mp:make-process. When *swank-thread* is T then make the new thread + inherit "sliminess": debugger hook, I/O streams, and also + *swank-thread* so that its children will inherit too. + +2004-07-03 Luke Gorrie <luke(a)bluetail.com> + + * hyperspec.el (common-lisp-hyperspec-section-4.0): Bugfix from + Lennart Staflin. + + * slime.el (slime-repl-clear-output): Avoid clearing the previous + REPL expression too. Patch from Andras Simon. + + * swank-backend.lisp (definterface): Don't use + NO-APPLICABLE-METHOD for default methods. Instead just define them + as regular methods with all argument types being + T. Defimplementation will then replace them by using the same + signature. N-A-M was a stupid idea! + +2004-07-02 Brian Downing <bdowning(a)lavos.net> + + * slime.el (slime-reindent-defun): Added a check for (boundp + 'slime-repl-input-start-mark) before checking the variable, as + XEmacs leaves variables unbound when `make-variable-buffer-local' + is run, while GNU Emacs binds them to NIL. + +2004-07-02 Martin Simmons <martin(a)xanalys.com> + + * swank-lispworks.lisp (dspec-stream-position, + make-dspec-location): Fix typo in features for LW 4.1 and 4.2. + +2004-07-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-lispworks.lisp (frame-actual-args): Bind + *break-on-signals* to nil and special case &rest, &optional, and + &key. + +2004-07-01 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (sldb-lookup-reference): Preserve case in SBCL node + names. Previously they were downcased, but the HTML manual's + filenames seem to have changed. + + * NEWS: Added security note about the TCP server. + Added notes for ACL and ABCL. + + * doc/slime.texi: General updatings for an alpha release. + +2004-06-30 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-display-compilation-output): New customizable + variable. + + * swank.lisp: Minor cleanups. + (find-symbol-designator, find-symbol-or-lose) + (case-convert-input): Deleted. Replaced with calls to + parse-symbol{-or-lose}. + + * swank-lispworks.lisp (describe-symbol-for-emacs): Include + information about setf-functions. + (emacs-connected): Add a default method to + env-internals:environment-display-debugger. + +2004-06-30 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-read-port-and-connect-to-running-swank) + (slime-connect, slime-open-stream-to-lisp): Replace "localhost" + with "127.0.0.1". This is believed to avoid unwanted DNS lookups + on certain operating systems. The lookups can become crippling if + the DNS server isn't available. + (line-beginning-position, line-end-position): Simple bugfix + suggested by Richard Klinda. + + * swank-sbcl.lisp (preferred-communication-style): Choose + :fd-handler instead of :sigio when threads aren't available. A lot + of people seem to have had problems with :sigio on SBCL. + +2004-06-30 Luke Gorrie <luke(a)bluetail.com> + + * NEWS: Wrote preliminary release notes for alpha-1. + +2004-06-29 Luke Gorrie <luke(a)bluetail.com> + + * mkdist.sh: New shell script for creating a tarball for + distribution. + +2004-06-29 Bill Clementson <Bill_Clementson(a)peoplesoft.com> + + * slime.el (slime-who-map): Add extra bindings for the XREF + commands as with the documentation commands. Now `C-c C-w C-c' is + `slime-who-calls' in addition to `C-c C-w c', etc. + +2004-06-29 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (sldb-prune-initial-frames): Tweaked regexp for + matching SWANK's own stack frames for effectiveness in SBCL. + (slime-keys): Shadow remaining inf-lisp keys (C-c C-a, C-c C-v) + with a null `slime-nop' command until we put them to a real use. + + * swank.lisp (open-streams): Renamed the restart around reads from + the user-input stream from ABORT to ABORT-READ. Invoking this + restart seems kinda dangerous, so better for 'a' in SLDB not to do + so. + +2004-06-28 Thomas F. Burdick <tfb(a)OCF.Berkeley.EDU> + + * swank.lisp (inspector-nth-part): + * slime.el (slime-inspector-copy-down, slime-inspector-mode-map): + Added copy-down command (M-RET) to easily move an object from the + inspector to the repl. + +2004-06-28 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-doc-map): New keymap for documentation + commands. These all use the `C-c C-d' prefix, followed by: + a - apropos + p - apropos-package + z - apropos-all + d - describe-symbol + f - describe-function + h - hyperspec lookup + ~ - hyperspec lookup of a format character + The final keystroke is bound both unmodified and with control, so + both `C-c C-d a' and `C-c C-d C-a' will make an apropos + search. The exception is hyperspec-lookup, because it's nice to + leave C-h unbound so that `C-c C-d C-h' will summarise the + documentation bindings. + +2004-06-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-allegro.lisp (nth-frame): Skip frames where + frame-visible-p is false. + + * slime.el (slime-buffer-package): Return the cached package if we + can't find something more sensible; this reverts a previous + change. The Lisp side will now fall back to an existing package + if the one supplied by Emacs doesn't exist. Using the cached + version is also necessary for some commands in the apropos buffer. + (sldb-insert-frame): Set the default-action property; pressing RET + on frame lines now shows/hides details. + (sldb-toggle-details): Preserve the current column. + (slime-inspector-buffer, slime-saved-window-config) + (slime-inspector-quit): Save and restore the window configuration. + (slime-highlight-suppressed-forms, slime-search-suppressed-forms): + Display expressions with reader conditionals (#+/#-) in + font-lock-comment-face if the test is false. Not implemented for + XEmacs. + (repl-return): New test. + +2004-06-28 Luke Gorrie <luke(a)bluetail.com> + + * slime.el: Events in the *slime-events* buffer are now exact + on-the-wire messages, without including e.g. Elisp continuation + functions. This is easier for debugging I think. + + * swank-allegro.lisp (compute-backtrace): Only include frames + satisfying `debugger:frame-visible-p'. I did this as a lame + workaround for a problem where `output-frame' was segfaulting on + certain frames, and those frames happened not to be visible-p. I + don't know if it really fixes anything. + + * hyperspec.el (common-lisp-hyperspec-format): This command now + works at the end of the buffer, fixed `char-after' usage as + suggested by Johan Bockg�rd. + +2004-06-28 Christophe Rhodes <csr21(a)cam.ac.uk> + + * hyperspec.el: add support for issue cross-reference lookups, + strongly inspired by hyperspec symbol lookup. + (common-lisp-hyperspec-issuex-table, + common-lisp-hyperspec-issuex-symbols): new variables + (common-lisp-issuex): new function + + * slime.el (sldb-format-reference-node, sldb-lookup-reference): + (sldb-reference-properties): use new support for issue lookups + to support :ansi-cl :issue reference types. + + * hyperspec.el: add support for glossary lookups. + (common-lisp-glossary-fun): new variable + (common-lisp-glossary-4.0, common-lisp-glossary-6.0): new functions + + * slime.el (sldb-format-reference-node, sldb-lookup-reference): + (sldb-reference-properties): use new support for glossary lookupts + to support :ansi-cl :glossary reference types. + +2004-06-27 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * doc/slime.texi: Remove macros from chapter and section headings + to avoid texi2pdf breakage. + + * swank-source-path-parser.lisp (cmucl-style-get-macro-character): + Add tests for #\space and #\\. Suggested by Christophe Rhodes. + + * swank-sbcl.lisp, swank-openmcl.lisp, swank-lispworks.lisp, + swank-cmucl.lisp, swank-backend.lisp, swank-allegro.lisp, + swank-abcl.lisp (thread-id, find-thread): New backend functions. + + * swank.lisp (dispatch-event): Quitting from the debugger was + seriously broken. Fix it. Move generation of thread ids to the + backends. + (encode-message, send-to-socket-io): Use WITHOUT-INTERRUPTS in + send-to-socket-io. The multithreaded version of encode-message + doesn't need it. + (nth-thread): Renamed from lookup-thread-by-id. + (debug-nth-thread): Renamed from debug-thread-by-id: + (kill-nth-thread): Renamed from kill-thread-by-id. + + * slime.el (sldb-get-buffer): Add support for sldb buffers for + multiple threads. + +2004-06-25 Thomas F. Burdick <tfb(a)OCF.Berkeley.EDU> + + * swank-sbcl.lisp (call-with-syntax-hooks, with-debootstrapping): + Preserve compatability with fairly recent SBCLs by checking for + the presense of the debootstrapping facilities at macroexpansion + time. + + * slime.el (sldb-insert-condition): Initialize sldb-default-action + so that pressing RET inspects the condition. + +2004-06-25 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-repl-insert-prompt): Set defun-prompt-regexp. + beginning-of-defun can be very slow in the repl buffer if the + defun-prompt-regexp is not set. + (sldb-insert-locals): Initialize sldb-default-action. + (sldb-var-number-at-point, sldb-inspect-var): New function. + + * swank.lisp (inspect-frame-var): New function. + + * swank-backend, swank-cmucl.lisp, swank-sbcl.lisp, + swank-allegro.lisp, swank-lispworks.lisp, swank-clisp.lisp + (frame-var-value): New backend function. + +2004-06-24 Christophe Rhodes <csr21(a)cam.ac.uk> + + * slime.el (sldb-format-reference-node): fix for when `what' is a + list. + (sldb-lookup-reference,sldb-reference-properties): support + :ansi-cl :section reference types. + + * hyperspec.el (common-lisp-hyperspec-6.0): generalize to work + with section numbers lower than 10. + +2004-06-24 Brian Downing <bdowning(a)lavos.net> + + * slime.el (slime-repl-send-input): Fixed a subtle difference in + sending input to the Lisp introduced in 1.316. The newline was + not getting sent, resulting in the Lisp constantly asking for more + read data. I believe the code has been adjusted to behave the + same as 1.315 with regard to sending newlines. + Also adjusted the `slime-repl-old-input' text property to end just + before the newline, not just after. This causes a gap between + inputs even if no Lisp output appeared in between, so that putting + point on an old line and hitting RET will only call up that line, + and hitting RET in the middle of the current line will send it and + not bring up a confusing combination of all previous input. + Many thanks to Loyd Fueston for pinpointing the date and exact + patch for when this problem was introduced. + +2004-06-23 Brian Downing <bdowning(a)lavos.net> + + * slime.el: Re-added most of Luke's patches from yesterday. It + has the shortened names, uses markers instead of stored `(point)' + values, and `slime-fuzzy-complete-symbol' is an option for + `slime-complete-symbol-function'. + It still string compares the target buffer instead of using + `(buffer-modified-tick)'. + I left the `C-c M-i' keybinding in, as it allows use of the + regular completion as well. If there's an objection to this it + can be removed. + `window-configuration-change-hook' is used if the variable is + present, and ignored it not. This neatly sidesteps its absence in + XEmacs while not killing the functionality for GNU Emacs. + + * doc/slime.texi: Added a command entry and short description for + `C-c M-I, slime-fuzzy-complete-symbol', and added its existence to + the `slime-complete-symbol-function' documentation. + +2004-06-22 Luke Gorrie <luke(a)bluetail.com> + + * doc/slime.texi: Noted ABCL support. + + * slime.el: Backed out all of my changes to fuzzy completion. I + was too hasty and didn't do good things. Now it's back in pristine + state from Brian's patch -- use `C-c M-i' to fuzzy-complete. + + * doc/Makefile (contributors.texi): The contributors list in the + manual is now sorted by most number of ChangeLog entries. Patch + from Michael Weber. + + * slime.el: Some minor hacking to fuzzy completion: + Use the shorter `slime-fuzzy-' symbol prefix. + Use markers instead of numbers to remember where the completion is + being done. This way they are self-updating. + Use `buffer-modified-tick' to detect modifications instead of text + comparison. + Always restore window configuration when a completion is + chosen. For this completion style I think this will work okay + [famous last words], and the existing code wasn't + XEmacs-compatible for want of window-configuration-change-hook. + Now there is no separate keybinding for fuzzy completion, but it's + included as a customize option for `slime-complete-symbol-function' + +2004-06-22 Brian Downing <bdowning(a)lavos.net> + + * slime.el, swank.lisp: Added "fuzzy completion." + +2004-06-22 Matthew Danish <mdanish(a)andrew.cmu.edu> + + * swank-backend.lisp (unbound-slot-filler): New structure for + representing an unbound slot in the inspector functions. + + * swank.lisp, swank-allegro.lisp: Use it. + +2004-06-22 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-output-filter): Choose connection based on + process-buffer, not current buffer. This fixes a bug where output + from multiple Lisp sessions could get mixed up. + (slime-kill-all-buffers): Include all *inferior-lisp*[<n>] buffers. + Split the customize settings into more subgroups. + + * swank.lisp (prefixed-var): Intern *REAL-STANDARD-INPUT* etc in + the SWANK package instead of the COMMON-LISP package. + +2004-06-21 Luke Gorrie <luke(a)bluetail.com> + + * swank-loader.lisp (*lisp-name*): Add version number to + Lispwork's fasl directory. We should do this for ACL and OpenMCL + too, but for some reason my ACL 5.0 gets an error when trying to + create a directory with a version number in its name, and I don't + have OpenMCL to test with. + + * swank-backend.lisp, swank.lisp (add-hook, run-hook): Moved the + hook mechanism and all hooks to swank.lisp (from + swank-backend.lisp). There is no compelling use for the hooks in + backends yet and I want to pass swank.lisp-internal data + structures in the existing hooks. + (notify-backend-of-connection): Call `emacs-connected' with the + user-io stream for its argument. Should fix previous breakage + where the connection structure was passed instead. + (*globally-redirect-io*): New configurable: when true the standard + streams are globally redirected to Emacs. That way even + e.g. SERVE-EVENT handlers will print to Emacs. Currently does not + handle standard input -- that is trickier since the Lisp's native + REPL can be trying to read from that. + + * slime.el (slime-complete-maybe-restore-window-configuration): + Only restore the window configuration if the completions buffer is + currently visible in the window that we popped it up in. + (slime-complete-maybe-save-window-configuration): Don't save the + window configuration if the completions buffer is already visible. + (slime-repl-return): Make sure the newline goes at the end of the + input, not at point. + (slime-complete-restore-window-configuration): Wrap the + `set-window-configuration' call in (run-at-time 0 ..). XEmacs does + not allow us to set the window configuration from inside + pre-command-hook. + +2004-06-20 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-sbcl.lisp (emacs-connected): Set *invoke-debugger-hook* to + our debugger hook. Not optimal, but at least BREAK will then + invoke our debugger. + (*trap-load-time-warnings*): New variable. If it is true, + conditions, most notably redefinition warnings, signalled at load + time are not trapped. + (swank-compile-file, swank-compile-string): Use it. + + * swank.lisp (guess-buffer-package): Don't signal a continuable + error if the package doesn't exists; that's too annoying. + + * slime.el: Fix outline structure. + (slime-maybe-list-compiler-notes): Fix thinko. + (break): New test. Reorganize the test-suite a bit to support + "expected failures". + (slime-eval-feature-conditional, slime-to-feature-keyword): Add a + ?: to the symbol-name if needed. + +2004-06-20 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp (changelog-date): Removed unneeded function. + (connection-info): No more version field in result. + + * slime.el: Audited to remove namespace slipups. Tracking a really + horrible clashing-with-some-user-configuration bug and want to + eliminate potential symbol conflicts. + (sldb-get-buffer): Renamed from `get-sldb-buffer'. + (slime-emacs-20-p): Renamed from `emacs-20-p'. + (slime-defun-if-undefined): Renamed from `defun-if-undefined'. + (slime-isearch): Small bugfix that could cause M-. to go to the + wrong place in CMUCL. + (slime-changelog-date, slime-check-protocol-version): Removed + unneeded functions. + + * swank-backend.lisp (add-hook, run-hook): Added an Emacs-like + hook mechanism. The hope is that this will make some sections of + the code more self-describing by showing where they hook in. + (*new-connection-hook*): Hook run when a new connection is + established. Initialized to '(swank-backend:emacs-connected). + (*pre-reply-hook*): Hook run before sending a reply to Emacs. + + * swank.lisp: Added some comments and docstrings. + (package-external-symbols): Removed unused function. + (serve-connection): Call *new-connection-hook*. + (eval-for-emacs): Call *pre-reply-hook*. + (sync-features-to-emacs, sync-indentation-to-emacs): Added to + *pre-reply-hook*. + (cl-package, keyword-package): Now defconstant instead of + defvar. Removed the *'s accordingly. + + * slime.el (slime-abort-connection): Renamed from + `slime-connection-abort'. The new name is easier to find with + completion. + + * swank-sbcl.lisp: Change sb-posix:: to sb-posix: + +2004-06-19 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp (known-to-emacs-p): Bugfix. Indentation-updates was + broken. + +2004-06-18 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-buffer-package): If DONT-CACHE is true and no + package name can be found, then default to "COMMON-LISP-USER." + Previously we just kept using the cached version, but that could + lead to error-after-error if it was incorrect. + + * swank.lisp (throw-to-toplevel): If our top-level catcher isn't + on the stack (i.e. we're using the debugger from outside an RPC) + then ABORT instead. That makes 'q' DWIM in SLDB. + +2004-06-18 Matthew Danish <mdanish(a)andrew.cmu.edu> + + * swank-allegro.lisp (frame-source-location-for-emacs): + Implemented. + +2004-06-18 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-repl-return): If the user presses return on old + REPL input then take it and insert it as the current input. + Signal an error if the point is not on any input. + (slime-preserve-zmacs-region): Function to ensure that the current + command doesn't deactivate zmacs-region (XEmacs only). + (slime-repl-bol, slime-repl-eol): Use it. + (slime-kill-all-buffers): Changed buffer-name regexps for XEmacs + compatibility. The ",quit" shortcut now works in XEmacs. + (slime-display-message): Fixed call to `slime-typeout-message' + to handle formatting characters. Avoids errors on certain messages. + (slime-list-compiler-notes): Save the window configuration + earlier. This fixes an error under XEmacs when dismissing the + notes buffer. + (slime-recenter-window): Avoid moving the point. This keeps the + point in the right place when showing debugger-frame locations in + Emacs 21. + +2004-06-17 Luke Gorrie <luke(a)bluetail.com> + + * swank-loader.lisp (binary-pathname): Place fasl files under + ~/.slime/fasl/ instead of the SLIME installation directory. The + installation directory can now be read-only. + (binary-pathname, user-init-file): Removed Win32 + conditionalization. The init file is now called ~/.swank.lisp + instead of ~/_swank.lsp. + + * swank-lispworks.lisp (with-fairly-standard-io-syntax): New + macro. Like with-standard-io-syntax, but keeps the existing values + of *package* and *readtable*. + (dspec-stream-position): Use it. + (quit-lisp): Implemented. + +2004-06-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-set-default-directory): Don't call + slime-repl-update-banner in Emacs 20. + (slime-show-source-location, slime-recenter-window): Use + set-window-start instead of recenter; this avoids flickering. + (sldb-list-locals): Don't forget about slime-current-thread in the + temporary buffer. (Fixes bug reported by Mike Beedle.) + (sldb-step): Re-enabled. The CMUCL backend has rudimentary support + for stepping. + + * swank.lisp (*readtable-alist*): Call backend function for + initialization. + (eval-for-emacs, guess-buffer-package): Signal a continuable error + if a package name was supplied but no such package exists. Not + sure if this is better than what we did before (i.e. silently use + the current package). + + * swank-cmucl.lisp (default-directory): Add implementation. + (sldb-step): Uncomment it and remove references to + *swank-debugger-condition*. + + * swank-backend.lisp (sldb-step, default-readtable-alist): New + backend functions. + (emacs-connected): Pass the redirected stream as argument, so that + the OpenMCL backend can add it to CCL::*AUTO-FLUSH-STREAMS*. + + * swank-sbcl.lisp (default-readtable-alist): Implement it. + + * swank-loader.lisp: Move readtable-alist initialization to + swank-sbcl.lisp. + + * swank-allegro.lisp (default-directory, call-with-syntax-hooks): + Add implementations as workarounds for ACL5 bugs. + +2004-06-16 Lawrence Mitchell <wence(a)gmx.li> + + * slime.el (slime-maybe-rearrange-inferior-lisp): Call + `generate-new-buffer-name' manually, rather than relying on the + UNIQUE argument to `rename-buffer' to do so. + +2004-06-16 Frederic Brunel <frederic.brunel(a)in-fusio.com> + + * slime.el (slime-startup-animation): Use defcustom to declare the + variable. + (slime-enable-startup-animation-p): Deleted. + +2004-06-16 Robert Lehr <bozzio(a)the-lehrs.com> + + * slime.el (slime-backend): This variable can now be set to an + absolute filename. + +2004-06-15 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-compile-file): Just prompt for saving the + current file instead of calling `save-some-buffers'. Based on a + patch from Brian Downing. + +2004-06-12 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * wank-allegro.lisp (format-sldb-condition, condition-references): + Add workarounds for buggy no-applicable-method. + + * swank.lisp (parse-symbol, parse-package): Handle reader errors. + + * swank-openmcl.lisp (send, receive): Ensure that messages are + never nil. + +2004-06-10 Christophe Rhodes <csr21(a)cam.ac.uk> + + * swank-sbcl.lisp (call-with-syntax-hooks): Add hooks to fix + "SB!"-style package names. + (shebang-readtable): Return a readtable with readermacros needed + to parse SBCL sources. + + * swank.lisp (with-buffer-syntax): New macro. This should be used + for code which needs to READ code from Emacs buffers. *package* + and *readtable* are bound suitable values. + (to-string, format-values-for-echo-area, interactive-eval) + (eval-region, interactive-eval-region, re-evaluate-defvar) + (swank-pprint, pprint-eval, listener-eval) + (compile-string-for-emacs, disassemble-symbol, describe-to-string) + (describe-symbol, describe-function) + (describe-definition-for-emacs) + (documentation-symbol, init-inspector, inspect-nth-part) + (inspector-pop, inspector-next, describe-inspectee) + (inspect-current-condition): Use it. + +2004-06-10 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-loader.lisp: Initialize swank::*readtable-alist* for SBCL. + + * swank-backend.lisp (default-directory, call-with-syntax-hooks): + New functions. + + * swank.lisp (*readtable-alist*): New configurable. The keys are + package name and the values readtables. The readtable will be + used to READ code originating from Emacs buffers in the associated + slime-buffer-package. + (drop-thread): Simplified. + (*buffer-readtable*): New variable. + (parse-package): New function. + (parse-string): Renamed from symbol-from-string. Make it case + insensitive. + (eval-for-emacs): Initialize the *buffer-readtable*. + (symbol-indentation): Don't consider symbols in the CL package. + Emacs already knows how to indent them. + (compile-file-if-needed): Used for REPL shortcut + 'compile-and-load'. + + * slime.el (pwd): Re-add REPL shortcut. + (slime-repl-push-directory, slime-repl-compile-and-load): Simplified. + +2004-06-10 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (sldb-step): Command is disabled because the function + `swank:sldb-step' that it calls doesn't exist. I don't see any + stepping code in our backends. + +2004-06-09 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-goto-location-position) [:function-name]: The + function name can also occur after a ?(, not only after + whitespace. + + * (slime-init-output-buffer): Initialize the package stack. + Reported by Rui Patroc�nio. + + * (slime-completions): Make it consistent with + slime-simple-completions. The second argument was never supplied. + Reported by Rui Patroc�nio. + +2004-06-09 Eric Blood <eblood(a)winkywooster.org> + + * slime.el (slime-indent-and-complete-symbol): Renamed from + slime-repl-indent-and-complete-symbol. + + (slime-typeout-frame-properties): Add more default options for the + typeout frame--specifically it now has a default width, and moves + the typeout frame to the upper right. + +2004-06-09 Andras Simon <andras(a)renyi.hu> + + * swank-abcl.lisp: New backend for Armed Bear Common Lisp. + + * swank-loader.lisp: Add ABCL support. + +2004-06-09 Martin Simmons <martin(a)xanalys.com> + + * swank-lispworks.lisp (dspec-stream-position): New function to + make source location work for anything complicated e.g. methods. + (with-swank-compilation-unit): Refactoring. + (who-macroexpands): Implemented. + (list-callers): Implemented. + + * swank-backend.lisp (network-error): Inherit from simple-error to + get correct initargs. + +2004-06-09 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (sldb-insert-references): Added support for hyperlinked + references as part of conditions being debugged. This is a new + feature in SBCL to reference appropriate sections of their manual + or CLHS from condition objects. The references are clickable. + + * swank-backend.lisp (format-sldb-condition): New backend function + to format conditions for SLDB. + (condition-references): New function to return a list of + documentation references associated with a condition. + + * swank.lisp (debugger-condition-for-emacs): Call the above + backend functions to add a `references' list for Emacs. + + * swank-sbcl.lisp (format-sldb-condition, condition-references): + Implemented. Requires a recent (latest?) SBCL release. + +2004-06-08 Luke Gorrie <luke(a)bluetail.com> + + * swank-cmucl.lisp (close-socket): Remove any SERVE-EVENT handlers + for the socket's file descriptor. + + * swank-sbcl.lisp (close-socket): Same fix. + +2004-06-07 Luke Gorrie <luke(a)bluetail.com> + + * swank-cmucl.lisp: Minor refactorings. + +2004-06-07 Edi Weitz <edi(a)agharta.de> + + * swank-allegro.lisp (call-with-compilation-hooks): Implemented. + Wrap IMPORT call in EVAL-WHEN. + + * swank.lisp, swank-backend.lisp: Wrap EXPORT calls in + EVAL-WHEN. Fixes many warnings in ACL. + +2004-05-25 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-kill-without-query-p): Default to T. + (sldb-highlight): Variable to control face-based highlighting of + SLDB locations. (In Emacs21 the point is visible even in unselected + windows, which is sufficient for me.) + (sldb-show-location-recenter-arg): Argument to `recenter' when + showing SLDB locations. Default to nil, i.e. location appears in + the middle of the window. + +2004-05-24 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-input-complete-p): Return nil for unbalanced + sexps starting with quote ?', backquote ?`, or hash ?#. C-j can + be used for more complicated cases. + +2004-05-22 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-repl-sayoonara): Added "quit" as an alias for + sayoonara. + +2004-05-22 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-cmucl.lisp (arglist): Catch (reader) errors in + READ-ARGLIST. + + * swank-allegro.lisp (fspec-primary-name): New function. + (find-fspec-location): Use it, if the start position cannot be + found. + + * slime.el (slime-pprint-event): New function. + (slime-log-event): Use it. + (slime-reindent-defun): Indent the form after point, if point is + in the first column an immediately before a #\(. + +2004-05-21 Bill Clementson <Bill_Clementson(a)peoplesoft.com> + + * slime.el (slime-switch-to-output-buffer): Use "P" as interactive + spec. + +2004-05-21 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-switch-to-output-buffer): Override the + prefix-arg if we are called non-interactively. + (slime-repl-current-input): Don't add newlines. + (slime-repl-return): Send input if we are in read-mode also if it + isn't a complete expression. + (repl-read-lines): New test case. + (slime-enable-startup-animation-p): New configurable. + (slime-repl-update-banner): Use it. + (slime-hide-inferior-lisp-buffer): New function. Reuse the + *inferior-lisp* buffer window for the SLIME REPL. + + * swank-allegro.lisp (find-fspec-location): Better handling of + methods. From Bill Clementson. + +2004-05-17 Luke Gorrie <luke(a)bluetail.com> + + * xref.lisp, swank-clisp.lisp: Renamed XREF package to PXREF (P + for portable). This makes it possible to load the package in + e.g. CMUCL, which is nice because it's a good package. + + * swank-cmucl.lisp: Some refactoring and high-level + commenting. Mostly just trying to organise things into fairly + self-contained sections (my new hobby, sad I know!) + + * slime.el: Added `C-c C-e' as an alternative binding for + `slime-interactive-eval' (usually `C-c :'). This seems slightly + more convenient, and has the added bonus of clobbering an unwanted + `inf-lisp' binding. + +2004-05-14 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-with-output-to-temp-buffer): Now takes a + package arg specifying what slime-buffer-package should be in the + generated buffer. + (slime-show-description): actually pass the package arg. + (slime-show-apropos): pass the package arg to + slime-with-output-to-temp-buffer. + (slime-list-repl-shortcuts): pass a package arg. + +2004-05-12 Alan Ruttenberg <alanr-l(a)mumble.net> + * swank-openmcl.lisp: Fixes to support openmcl 0.14.2 changes in + backtrace protocol, from Gary Byers. + - Replace string "tcr" to "context". + - Change the call to %current-tcr in map-backtrace to get-backtrace-context, + defined so as to be back compatible with 0.14.1. + - Change the call to %catch-top to explicitly use %current-tcr + instead of the passed in tcr-which-is-now-called-context. + + Users of map-backtrace (outside of slime code) note: The tcr position in the + function call is now occupied by the backtrace "context" which is always nil. + If you really need the tcr then you need to call %current-tcr yourself now. + + Gary comments: The part that's a little hard to document about + the new "context" stuff - used to walk the stacks of thread A from + thread B - is that thread B has to be aware of when a context + becomes invalid (a context describing part of thread A's stack is + valid while thread A's sitting in a break loop and becomes invalid + as soon as it exits that break loop.) A thread sort of announces + when a context becomes valid and when it becomes invalid; whether + and how SWANK could hook into that isn't yet clear. + + * swank-openmcl.lisp: Minor changes to backtrace display: Anonymous + functions names in function position surrounded by #<>. Use prin1 instead of + princ to print function arguments (so strings have "s around them). + prefix symbol and list arguments by "'" to make them more look like a + valid function call. Let me know if you don't like this... + +2004-05-12 Luke Gorrie <luke(a)bluetail.com> + + * slime.el: Fixes for outline-mode in *slime-events* from Edi + Weitz. + +2004-05-11 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-events-buffer): Disable outline-mode by default. + (slime-inhibit-ouline-mode-in-events-buffer): New variable. + (slime-expected-failures): Reduce the number for SBCL. + + * swank-sbcl.lisp (resolve-note-location): Resolve the location if + we are called by swank-compile-string. The pathname argument is + never :stream in SBCL, so the method written for CMUCL was never + called. + +2004-05-10 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp (from-string): Bind *READ-SUPPRESS* to NIL. + (swank-compiler): Bind a restart to abort compilation but still + report the compiler messages already trapped. + (string-to-package-designator): Function that uses READ to + case-convert package names. + (apropos-list-for-emacs): Use it. + + * slime.el (slime-eval-with-transcript): Don't print the "=>" + prefix in messages showing evaluation results. It mucks up + alignment in multi-line messages. + (sldb-eval-in-frame): Don't print "==>" prefix on evaluation + results, for the same reason. + (slime-show-source-location): Move the point to the source + location in addition to highlighting the matching parens. + +2004-05-08 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-cmucl.lisp (find-definitions): Add support for variables + and constants. + +2004-05-07 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-clisp.lisp (compiler-note-location): Use make-location to + instead of `(:location ...). This initializes the new hint slot + automatically. + +2004-05-07 Barry Fishman <barry_fishman(a)att.net> + + * swank.lisp (prin1-to-string-for-emacs, arglist-to-string): CVS + CLISP prints NIL as |COMMON-LISP|::|NIL| if *print-readably* is + true. Set *print-readably* to nil for a more Emacs friendly + printer syntax. + +2004-05-06 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-maybe-list-compiler-notes): Display the notes + listing after C-c C-c only if there are no annotations in the + buffer. CMUCL creates usually one warning with an error location + and an almost redundant warning without at the end of the + compilation unit. Don't display the listing in this common case. + + (slime-reindent-defun): Pass nil as the third arument to + indent-region. + +2004-05-06 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-repl-sayoonara): Don't attempt to quit the lisp + if we're not connected. + + * swank-openmcl.lisp (*buffer-offset*, *buffer-name*): Supply + default values. This avoids unbound value errors when compiling an + asdf system signals errors. + +2004-05-04 Alan Shutko <ats(a)acm.org> + + * slime.el (slime-compiler-notes-show-details/mouse): New command. + (slime-compiler-notes-mode-map): Use it. + +2004-05-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-cmucl.lisp (arglist): Handle byte-code functions better. + We don't know much about the actual argument list, only the number + of arguments. Return at least something mildly interesting like + (arg0 arg1 &optional arg2 ...) + (function-location): Special-case byte-code functions. + + * swank-backend.lisp (with-struct): New macro. + +2004-05-04 Thomas F. Burdick <tfb(a)OCF.Berkeley.EDU> + + * slime.el (slime-reindent-defun): New command on C-M-q. Reindent + the current Lisp defun after trying to close any unmatched + parenthesis. If used within a comment it just calls fill-paragraph. + +2004-05-04 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-goto-location-position): Regexp fix. + (slime-reindent-defun): New command on M-q. Reindent the current + Lisp defun after trying to close any unmatched parenthesis. + + * swank.lisp: Remove (declaim (optimize ...)). The side-effect + this has on people's environment seems harmful (I saw someone + having trouble on the OpenMCL list). + + * swank-cmucl.lisp (source-location-from-code-location): Fixed a + bug where the source-file-cache was not really used. + Now always report the location based on source file (cached or + not) even if modified -- not falling back on regexps, which was + probably a misfeature. + + * slime.el: Remove `slime-cleanup-definition-refs'. + +2004-05-02 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-start-and-load): New command. Suggested by + Lars Magne Ingebrigtsen. + +2004-05-02 Lars Magne Ingebrigtsen <larsi(a)netfonds.no> + + * slime.el (slime-kill-without-query-p): New variable. + (slime-net-connect): Use it. + (slime-open-stream-to-lisp): Ditto. + (slime-maybe-start-lisp): Ditto. + +2004-05-02 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-goto-source-location): Added support for the + :snippet "hint" in a location specifier. If Lisp sends the + (initial) source text for the definition then Emacs isearches for + it in both directions from the given character position. This + makes M-. robust when the Emacs buffer has been edited. Requires + backends to provide this snippet information. + (slime-goto-location-position): Tightened up the regular + expressions for :function-name style location search. + (slime-cleanup-definition-refs): New function to do a little + post-processing on definition references from Lisp. Mostly this is + a hack: if POSITION is NIL then we fill it in with the function + name, ready for regexp search. I was in a hurry and it was easier + to do here, and it doesn't seem entirely unreasonable. + + * swank-backend.lisp (:location): Added a 'hints' property list + to the location structure. This is for extra information that + compliments the buffer/position. + + * swank-cmucl.lisp (code-location-stream-position): Position the + argument stream at the definition before returning. + (source-location-from-code-location): Include the :snippet hint + for Emacs (see above). The snippet will only be accurate provided + that the source file on disk has not been modified. + (*source-file-cache*) The contents of all source files consulted + for M-. are now cached if they match the version of the running + code. This is so that we can accurately lookup source locations + even when the file is modified, provided we manage to get the + right version (by file timestamp) at least once. + (source-location-from-code-location): If the right source version + is not available on disk or in our cache then let Emacs fall back + on a regular expression search. + +2004-05-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-lispworks.lisp (find-top-frame): New function used to hide + debugger-internal frames. + (call-with-debugging-environment): Use it. + +2004-05-01 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (sldb-abort): Print a message if the Emacs RPC + returns. It shouldn't, if ABORT manages to unwind the stack, but + it currently does in OpenMCL due to some bug. + (slime-edit-definition-fallback-function): Name of a function to + try if the builtin edit-definition finding fails. You can set + this to `find-tag' to fall back on TAGS. + + * swank.lisp (list-all-systems-in-central-registry): Use explicit + :wild in pathname for matching (needed in at least SBCL). + + * swank-openmcl.lisp: Removed obsolete `swank-compile-system'. + + * swank-sbcl.lisp: Removed obsolete `swank-compile-system'. + Removed some stale comments about supported features. + +2004-04-30 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-repl-update-banner): Don't print the working + directory. It rarely fits in a line and was only Emacs' + default-directory. M-x pwd is convenient enough. + + * swank.lisp (symbol-indentation): Don't infer indentation for + symbols starting with 'def' or 'with-'. It was wrong most of the + time and Emacs' defaults are better. + + * swank-lispworks.lisp (emacs-connected): Add methods to + stream-soft-force-output for socket-streams and + slime-output-streams. This flushes those streams automatically + (i assume it gets called when Lisp is idle). + +2004-04-29 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-repl-mode): Set slime-current-thread to + :repl-thread. + + * swank.lisp (thread-for-evaluation, dispatch-event): Accept + :repl-thread as thread specifier and dispatch evaluation and + interrupt request properly. + (repl-thread-eval, repl-eval): Deleted. We do the special casing in + thread-for-evaluation. + +2004-04-29 Lars Magne Ingebrigtsen <larsi(a)netfonds.no> + + * slime.el (slime-event-buffer-name): New variable. + (slime-events-buffer): Use it. + (slime-space-information-p): Ditto. + (slime-space): Use it. + (slime-reply-update-banner-p): Ditto. + (slime-repl-update-banner): Use it. + +2004-04-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-loader.lisp (*lisp-name*): Add versioning support for + CLISP. + + * swank-clisp.lisp (arglist): Trap exceptions and return + :not-available in that case. + + * swank.lisp (arglist-for-insertion): Don't use ~< ..~:@>. + CLISP's pretty printer can't handle it. + +2004-04-28 Luke Gorrie <luke(a)bluetail.com> + + * NEWS: Created a NEWS file for recording changes that we want + users to read about. + + * slime.el (slime-log-event): Use outline-minor-mode in + *slime-events* instead of hideshow-mode. It's more + reliable. (Patch from Lawrence Mitchell.) + +2004-04-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-net-connect): Bind inhibit-quit to nil, so that + we have a chance to interrupt Emacs if open-network-stream blocks. + (slime-complete-maybe-restore-window-configuration): Keep trying + after slime-repl-indent-and-complete-symbol. + (slime-space): Don't close the completion buffer. We don't know + the window-config before the completion, so leave the buffer open. + + * swank.lisp (create-server): New keyword based variant to start + the server in background. + (setup-server): Add support to keep the socket open for + single-threaded Lisps. + +2004-04-27 Luke Gorrie <luke(a)bluetail.com> + + * doc/slime.texi (Other configurables): Updated instructions on + globally installing SLDB on *debugger-hook*. + + * slime.el (slime-log-event): Better bug-avoidance with + hs-minor-mode. Hopefully XEmacs users can rest safely now. + (slime-prin1-to-string): Bind `print-escape-newlines' to nil. + (slime-set-connection-info): Commented out call to + `slime-check-protocol-version'. Let's see how we do without it. + (slime-oneway-eval): Removed unused function. + + * swank.lisp (oneway-eval-string): Removed unused function. + +2004-04-26 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp: Move definition of `with-io-redirection' above + `with-connection' to avoid a CLISP error. This is really weird. + (interactive-eval): Bind *package* to *buffer-package*, so that + `C-x C-e' and related commands evaluate in the expected package. + + * slime.el (sldb-insert-frames): Handle empty backtrace (I got one + in CLISP). + + * swank-allegro.lisp (arglist): Return :not-available if arglist + lookup fails with an error. + + * slime.el: Moved snippets of Common Lisp code into swank.lisp + from the thread control panel. (Remember, no CL code in slime.el!) + + * swank-loader.lisp (*lisp-name*): Include a short version number + in the Lisp name to separate FASL files for different + versions. Only implemented for CMUCL and SBCL sofar. + + * swank.lisp (ed-in-emacs): Avoid mutating the argument. + (spawn-repl-thread): Add a new thread for evaluating REPL + expressions. This same thread is used for all REPL + evaluation. This fixes some issues with variables like * and ** + in at least SBCL. + + * nregex.lisp: Typo fix (thanks Barry Fishman). + + * slime.el (slime-events-buffer): Don't use hideshow-mode in + XEmacs for the *slime-events* buffer. It causes obscure problems + for some users. Still used in GNU Emacs. + +2004-04-25 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-backend.lisp (arglist): Return a list or :not-available. + Don't return strings or raise exceptions. + + * swank.lisp (arglist-for-echo-area): Simplified and adapted for + the new semantic of ARGLIST. + (arglist-for-insertion): Now a separate function. + (read-arglist): Deleted. No longer needed. + + * swank-cmucl.lisp, swank-lispworks.lisp (arglist): Return + :not-available if the arglist cannot be determined. + + * slime.el (slime-set-connection-info): Hide the *inferior-lisp* + buffer here, so that we have all the buffer rearrangement in one + place. + (slime-insert-arglist): Use swank:arglist-for-insertion. + +2004-04-24 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-init-connection-state): Use an asynchronous RPC + instead of slime-eval to reduce the amount of work we do in the + timer function. We can remove the workaround for the timer + problem. + +2004-04-23 Luke Gorrie <luke(a)bluetail.com> + + * slime.el: Updated top comments. + Make SLIME faces inherit from their font-lock cousins properly. + (slime-connect): Bind `slime-dispatching-connection' to avoid + being confused by old buffer-local variables when initializing + the connection. This fixes a bug where doing `M-x slime' from the + REPL could give a "Not connected" error. + +2004-04-22 Edi Weitz <edi(a)agharta.de> + + * slime.el (slime-read-system-name): Perform completion on all + systems in the central registry. + + * swank.lisp (list-all-systems-in-central-registry): New function. + +2004-04-22 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-repl-update-banner): Add workaround to force the + proper behavior of the the first command in the REPL buffer. + (slime-repl-shortcut-history): Define the variable to make XEmacs + happy. + +2004-04-22 Tiago Maduro-Dias <tcmd(a)rnl.ist.utl.pt> + + * slime.el (slime-space): Cleanup. + (slime-complete-restore-window-configuration): Use + slime-close-buffer instead of bury-buffer. + +2004-04-21 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: Suppress byte-compiler warnings by binding + byte-compiler-warnings to nil. + (slime-repl-shortcut): Use a structure instead of a list for the + short cut info. Update the users accordingly. + + * swank-cmucl.lisp (arglist): Return a list instead of the string. + +2004-04-21 Edi Weitz <edi(a)agharta.de> + + * slime.el (slime-apropos): Add support for regexp-based apropos. + We use nregex, so the regexp syntax is different from Emacs' + regexps and bit restricted (alternation '|' and optional groups + '(xy)?' are not implemented). + (slime-insert-arglist): New command - stolen from ILISP. I always + thought this was quite useful. + (slime-oos): Fix typo. + + * swank.lisp (apropos-symbols): Use regexp and support + case-sensitive matching. + (arglist-for-echo-area): New argument to control if the operator + name should be included. + + * nregex.lisp: New file. + + * swank-loader.lisp (*sysdep-pathnames*): Load it. + +2004-04-21 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * doc/slime.texi (Compilation): slime-remove-notes is bound to C-c + M-c not M-c. Noted by Edi Weitz. + +2004-04-21 Edi Weitz <edi(a)agharta.de> + + * swank.lisp (list-all-package-names): Optionally include + nicknames in the result. + + * slime.el (slime-read-package-name): Include nicknames in the + completions set. + (slime-repl-mode-map): Bind C-c : to slime-interactive-eval just + like in most other SLIME buffers. + (read-directory-name): Compatibilty defun. + +2004-04-20 Tiago Maduro-Dias <tcmd(a)rnl.ist.utl.pt> + + * slime.el (slime-close-buffer): New utility function. + (slime-space): Use it to kill superfluous *Completions* buffers. + +2004-04-17 Raymond Toy <rtoy(a)earthlink.net> + + * swank-cmucl.lisp (source-location-tlf-number) + (source-location-form-number): New functions to extract the + encoded form-numbers from source locations. + (resolve-stream-source-location, resolve-file-source-location): + Use them. + +2004-04-17 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-merge-notes): Use mapconcat instead of + (concat (slime-intersperse (mapcar ....))) + (slime-intersperse): Handle empty lists. + +2004-04-16 Luke Gorrie <luke(a)bluetail.com> + + * doc/Makefile: Added 'install' and 'uninstall' targets for the + Info manual. It may be necessary to tweak `infodir' in the + Makefile to suit the local system before installing. (Patch from + from Richard M Kreuter.) + + * doc/slime.texi (Top): The Top node is now smaller, with details + moved into Introduction. This makes the Info front page easier to + navigate. (Patch from Richard M Kreuter.) + +2004-04-15 Ivan Boldyrev <email@secret-by-request> + + * slime.el (slime-handle-repl-shortcut): Call `completing-read' + with an alist as expected, using `slime-bogus-completion-alist'. + +2004-04-14 Luke Gorrie <luke(a)bluetail.com> + + * doc/slime.texi (Shortcuts): Described REPL shortcuts. + + * slime.el (slime-oos): Generic ASDF interface. + (force-compile-system, compile-system, load-system, + force-load-system): New REPL commands. + + * swank-backend.lisp (operate-on-system): More generic interface + to ASDF. + + * swank.lisp (operate-on-system-for-emacs): More generic + interface to ASDF. + + * slime.el (slime-repl-mode-map): Portability fix for definition + of the REPL command character. + (slime-maybe-rearrange-inferior-lisp): Bugfix for running + multiple inferior lisps. + +2004-04-13 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-handle-repl-shortcut, + slime-list-all-repl-shortcuts, slime-lookup-shortcut, + defslime-repl-shortcut): Refactor repl shortcut code to provide a + more leggible help. + +2004-04-09 Lawrence Mitchell <wence(a)gmx.li> + + * slime.el (slime-same-line-p): Use `line-end-position', rather + than searching for a newline manually. + (slime-repl-defparameter): Use VALUE, not VALUE-FORM. + +2004-04-08 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-repl-package-stack): New buffer local variable. + (slime-repl-directory-stack): New buffer local variable. + (slime-repl-command-input-complete-p): Remove. + (slime-repl-update-banner): New function. + (slime-init-output-buffer): Use slime-repl-update-banner. + (slime-repl-shortcut-dispatch-char): New variable. + (slime-repl-return): Don't check for repl commands anymore. + (slime-repl-send-repl-command): Remove. + (slime-repl-mode-map): Bind slime-repl-shortcut-dispatch-char to + slime-handle-repl-shortcut. + (slime-set-default-directory): Use read-directory-name, call + slime-repl-update-banner. + (slime-repl-shortcut-table): New global variable. + (slime-handle-repl-shortcut): New function. + (defslime-repl-shortcut): New macro for defining repl shortcuts. + (slime-repl-shortcut-help, "change-directory", + slime-repl-push-directory, slime-repl-pop-directory, + "change-package", slime-repl-push-package, slime-repl-pop-package, + slime-repl-resend, slime-repl-sayoonara, slime-repl-defparameter, + slime-repl-compile-and-load): New repl shortcuts. + (slime-kill-all-buffers): Kill sldb buffers as well. + + * swank.lisp: Remove the repl related functions. + (requires-compile-p): New function. + +2004-04-07 Lawrence Mitchell <wence(a)gmx.li> + + * slime.el (slime-repl-prompt-face): New face. + (slime-repl-insert-prompt): Use it. + (slime-with-chosen-connection, with-struct): Docstring + fix for function's arglist display. + (when-let, slime-with-chosen-connection, with-struct): Docstring + fix for function's arglist display. + (slime-read-package-name): Use `slime-bogus-completion-alist' to + construct completion table. + (slime-maybe-rearrange-inferior-lisp): Use `rename-buffer's + optional argument to rename uniquely. + (slime-check-connected): Display keybinding for `slime' via + `substitute-command-keys'. + (slime-repl-send-repl-command): Use whitespace character class in + regexp. + (slime-autodoc-stop-timer): New function. + (slime-autodoc-mode): Add `interactive' spec to specify optional + arg. This allows prefix toggling of mode (behaves more like + most Emacs modes now). Stop timer if switching mode off with + `slime-autodoc-stop-timer'. + (slime-autodoc-start-timer, slime-complete-symbol) + (slime-complete-saved-window-configuration) + (slime-insert-balanced-comments): Docstring fix. + (slime-ed): Call `slime-from-lisp-filename' on filename for list + case of argument. + (slime-insert-transcript-delimiter, slime-thread-insert): Use + ?\040 to indicate SPC. + (line-beginning-position): `forward-line' always puts us in + column 0. + (line-end-position): Define if not fboundp (for older XEmacs). + +2004-04-07 Peter Seibel <peter(a)javamonkey.com> + + * swank-allegro.lisp (set-default-directory): Allegro specific + version that also uses excl:chdir. + + * swank.lisp (swank-pprint): Add swank versions of two missing + pretty-printer control variables. + +2004-04-07 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp (completion-set): Also complete package + names. (Patch from Sean O'Rourke.) + (find-matching-packages): Add a ":" to the end of package names + in completion. + +2004-04-06 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-bytecode-stale-p): Automatically check if + slime.elc is older than slime.el and try to help the user out if + so. + +2004-04-06 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-repl-command-input-complete-p): New function. + (slime-repl-send-string): New optional arg specifying what string + to put on slime-repl-input-history, usefull when this string + differs from what we actually want to eval. + (slime-repl-return): Check for repl commands and pass then to + slime-repl-send-repl-command. + (slime-repl-send-repl-command): New function. + (slime-kill-all-buffers): New function. + + * swank.lisp: Define the various repl command handlers: sayoonara, + cd, pwd, pack and cload. + + * swank-backend.lisp (quit-lisp): Define as part of the backend + interface and export. + + * swank-sbcl.lisp, swank-openmcl.lisp, swank-cmucl.lisp, + swank-clisp.lisp, swank-allegro.lisp (quit-lisp): implement. + +2004-04-06 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp (macro-indentation): Check that the arglist is + well-formed. This works around a problem with ACL returning + arglists that aren't real lambda-lists. + +2004-04-05 Lawrence Mitchell <wence(a)gmx.li> + + * swank.lisp (*swank-pprint-circle*, *swank-pprint-escape*) + (*swank-pprint-level*, *swank-pprint-length*): Fix typo in + docstring. + + * slime.el (slime-arglist): Don't `message' arglist directly, in + case it contains %-signs. + (slime-repl-output-face): Fix quoting. + (slime-symbol-at-point): Call `slime-symbol-name-at-point', + rather than ourselves. + (slime-check-protocol-version): Docstring fix. + +2004-04-05 Luke Gorrie <luke(a)bluetail.com> + + * doc/slime.texi (Semantic indentation): Documented new + automatically-learn-how-to-indent-macros feature. + Added auto version control header in subtitle. + + * slime.el (slime-close-parens-at-point): New command bound to + C-a C-a. Inserts close-parenthesis characters at point until the + top-level form becomes well formed. Could perhaps be made fancier. + (slime-update-indentation): New command to update indentation + information (`common-lisp-indent-function' properties) based on + macro information extracted from Lisp. This happens + automatically, the command is just to force a full rescan. + + * swank.lisp (connection): Added slots to track indentation caching. + (*connections*): List of all open connections. + (default-connection): Function to get a "default" + connection. This is intended to support globally using the + debugger hook outside the context of a SLIME request, which is + broken at present. + (with-connection): Don't setup a restart: that must be done + separately. + (sync-state-to-emacs): Call `update-connection-indentation'. + (update-connection-indentation): Automatically discover how to + indent macros and tell Emacs. + + * swank-backend.lisp (arglist): Specify that strings returned + from ARGLIST should be READable. + +2004-04-02 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-maybe-list-compiler-notes): Display the notes + for C-c C-c, when there are notes without a good source-location. + +2004-04-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-sbcl.lisp: Remove the non-working workarounds for + non-existent fcntl. Reported by Brian Mastenbrook. + (preferred-communication-style): Use multithreading if futexes are + available, sigio if fcntl is present, and fd-handlers otherwise. + (resolve-note-location): Don't try to construct a source-location + if there's no context. Notes without location will be displayed + in the note-listing buffer. + +2004-04-01 Bill Clementson <Bill_Clementson(a)peoplesoft.com> + + * swank-allegro.lisp (send): Fix misplaced parens. + +2004-03-31 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-cmucl.lisp (debug-function-arglist): Return symbols if + possible. + (class-location): Support for experimental source-location + recording. + +2004-03-30 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-repl-result-face): New face. + (slime-inspector-mode-map): Add a binding for M-. + (compile-defun): Add test case for escaped double quotes inside a + string. + + * swank.lisp (ed-in-emacs): New allowed form for argument. + (pprint-eval-string-in-frame): Apply arguments in proper order. + + * swank-cmucl.lisp (method-dspec): Include method-qualifiers. + (class-definitions): Renamed from struct-definitions. Try to + locate condition-classes and PCL classes (in the future). + (debug-function-arglist): Insert &optional, &key, &rest in the + right places. + (form-number-stream-position): Make it a separate function. + +2004-03-29 Lawrence Mitchell <wence(a)gmx.li> + + * swank.lisp (ed-in-emacs): New allowed form for argument. + + * slime.el (slime-ed): Deal with list form of argument. For a + list (FILENAME LINE [COLUMN]), visit the correct line and column + number. + +2004-03-29 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-source-path-parser.lisp (cmucl-style-get-macro-character): + New function. Workaround for bug(?) in SBCL. + (make-source-recording-readtable): Use it. + +2004-03-29 Luke Gorrie <luke(a)bluetail.com> + + * HACKING: Some small updates (more needed). + + * slime.el (slime-inspector-buffer): Enter `slime-inspector-mode' + after `slime-mode'. This seems to give priority of keymap to the + inspector, so that it can override SPC. + (slime-easy-menu): Add slime-switch-to-output-buffer. + Enable SLIME menu in the REPL buffer. + (slime-symbol-name-at-point): Avoid mistaking the REPL prompt for + a symbol. + (slime-words-of-encouragement): A few new ones. + (slime-insert-xrefs): Removed the final newline from XREF + buffers. This helps to avoid unwanted scrolling. + + * doc/slime.texi: Added a section about user-interface + conventions and our relationship with inf-lisp. + +2004-03-27 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-changelog-date): Reinitialize it at load-time. + This avoids the need to restart Emacs (horror!) after an update. + + * swank-cmucl.lisp (debug-function-arglist): Properly reconstruct + the arglist from the debug-info. (Not complete yet.) + (arglist): Use it. + + * swank-lispworks.lisp (spawn): Remove CL symbols from + mp:*process-initial-bindings*, to avoid the irritating behavior + for requests executed in different threads. E.g., when someone + tries to set *package*. + + * swank.lisp (*log-io*): New variable. Bind it to *terminal-io* + at load-time, so we can log to a non-redirected stream. + (disassemble-symbol): Allow generalized function names. + (apropos-symbols): Handle the PACKAGE argument properly to get + useful output for C-c P. + + * slime.el (slime-repl-indent-and-complete-symbol): New command. + Bound to TAB in the REPL mode. First try to indent the current + line then try to complete the symbol at point. + (slime-dispatch-event): Ignore a unused thread variable to keep + XEmacs' byte compiler quiet. + + * swank-sbcl.lisp (enable-sigio-on-fd): Use sb-posix::fcntl + instead of sb-posix:fcntl to avoid the ugly reader hack. SBCL + doesn't have package locks and even if they add locks in the + future sb-posix::fcntl will still be valid. + (getpid): Use defimplementation instead of defmethod. + (function-definitions): Take generalized function names ala '(setf + car)' as argument. + +2004-03-26 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-group-similar): Bugfix: return NIL if the input + list is NIL. + (slime-inspector-buffer): Enter `slime-inspector-mode' after + `slime-mode'. This seems to give priority of keymap to the + inspector, so that it can override SPC. + +2004-03-26 Bj�rn Nordb� <bn(a)telenor.net> + + * swank.lisp (print-arglist): Updated to handle arglists with + string elements, causing arglists for macros to display properly + in LW 4.1. + +2004-03-26 Marco Baringer <mb(a)bese.it> + + * swank-cmucl.lisp (set-default-directory): Define only once; + define with defimplementation, not defun. + +2004-03-26 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-merge-notes-for-display): New function to merge + together compiler notes that refer to the same location. This is + an optimization for when there are a lot of compiler notes: + `slime-merge-note-into-overlay' concat'd messages together one by + one in O(n^2) time/space, and became noticeably slow in practice + with ~100 notes or more. + (slime-tree-insert): This function is now automatically + byte-compiled (good speed gain). + Wrap byte-compilation in `save-window-excursion' to avoid showing + an unwanted warnings buffer (in XEmacs). + +2004-03-25 Bj�rn Nordb� <bn(a)telenor.net> + + * swank-lispworks.lisp: (create-socket, set-sigint-handler) + (who-references, who-binds, who-sets): Add backward compatibility + for LW 4.1. + (dspec-buffer-position): Fix inappropriate use of etypecase. + +2004-03-24 Luke Gorrie <luke(a)bluetail.com> + + * swank-sbcl.lisp (getpid): Use sb-posix:getpid. + + * slime.el (slime-inspector-mode-map): Added SPC as extra binding + for slime-inspector-next (like info-mode). + + * doc/slime.texi: Added completion style and configuration. + +2004-03-23 Alan Shutko <ats(a)acm.org> + + * swank-clisp.lisp (set-default-directory): New function. + +2004-03-23 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-allegro.lisp (send): Wait a bit if there are already many + message in the mailbox. + + * swank-clisp.lisp (xref-results): Use fspec-location instead of + the of fspec-source-locations. Reported by Alan Shutko. + (break): Be friendly to case-inverting readtables. + + * swank-lispworks.lisp (emacs-connected): Add default method to + environment-display-notifier. Reported by Bj�rn Nordb�. + (set-default-directory, who-specializes): Implemented for + Lispworks. + (gfp): New function. + (describe-symbol-for-emacs, describe-definition): Distinguish + between ordinary and generic functions. + (call-with-debugging-environment): Unwind a few frames. Looks + better and avoids the problems with the real topframe. + (interesting-frame-p): Use Lispworks dbg:*print-xxx* variables to + decide which frames are interesting. + (frame-actual-args): New function. + (print-frame): Use it. + + * swank.lisp (open-streams, make-output-function): Capture the + connection not only the socket. This way the streams can be used + from unrelated threads. Reported by Alain Picard. + (create-connection): Factorized. Initialize the streams after the + connection is created. + (initialize-streams-for-connection, spawn-threads-for-connection): + New functions. + (with-connection): Fix quoting bug and move upwards before first + use. + (guess-package-from-string): Add kludge for SBCL !-package names. + (apropos-list-for-emacs): Lispworks apparently returns duplicates; + remove them. + (inspect-object): Princ the label to allow strings and symbols. + (send-output-to-emacs): Deleted. + (defslimefun-unimplemented): Deleted. Was unused. + + * slime.el (slime-easy-menu): Add some more commands. + (slime-changelog-date): New variable. Initialized with the value + returned by the function of the same name. This detects + incompatible versions if Emacs has not been restarted after an + upgrade. + (slime-check-protocol-version, slime-init-output-buffer): Use it. + (slime-events-buffer, slime-log-event): Use fundamental mode + instead of lisp-mode to avoid excessive font-locking for messages + with lots of strings. + +2004-03-22 Luke Gorrie <luke(a)bluetail.com> + + * doc/slime.texi: New user manual. + + * swank.lisp (*communication-style*): New name for + *swank-in-background*. + Exported configuration variables: *communication-style*, + *log-events*, *use-dedicated-output-stream*. + +2004-03-20 Julian Stecklina <der_julian(a)web.de> + + * swank-sbcl.lisp (+o_async+, +f_setown+, +f_setfl+): Add correct + constants for FreeBSD. + +2004-03-19 Alan Shutko <ats(a)acm.org> + + * swank.lisp, swank-loader.lisp: Take into account + `pathname-device' when deriving paths. A fix for Windows. + +2004-03-19 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-connected-hook): New hook called each time SLIME + successfully connects to Lisp. This is handy for calling + `slime-ensure-typeout-frame', if you want to use that feature. + (sldb-print-condition): New command to print the SLDB condition + description into the REPL, for reference after SLDB exits. Can be + called from `sldb-hook' if you want the condition to always be + printed. Bound to 'P' in SLDB. + +2004-03-18 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp (format-values-for-echo-area): Bind *package* to + *buffer-package*. + (load-system-for-emacs): Renamed from swank-load-system. + (carefully-find-package): Be friendly to case inverting + readtables. + (inspect-current-condition): New function. + + * swank-backend.lisp, swank-cmucl.lisp (set-default-directory): + New backend function. + + * swank-allegro.lisp, swank-clisp.lisp, swank-lispworks.lisp, + swank-sbcl.lisp (swank-compile-string): Be friendly to + case-inverting readtables. + + * slime.el (sldb-inspect-condition): Use + swank:inspect-current-condition. + (slime-inspector-label-face): Make it bold by default. + (slime-check-protocol-version, slime-process-available-input): + Wait 2 secs after displaying the error message. + (sldb-list-catch-tags, sldb-show-frame-details): Display catch + tags as symbols not as strings. + +2004-03-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-dispatch-event, slime-rex): Pass a form instead + of a string with :emacs-rex. + (slime-connection-name): New connection variable. Use it in + various places instead of slime-lisp-implementation-type-name. + + * swank.lisp: Better symbol completion for case-inverting + readtables. (Thanks Thomas F. Burdick for suggestions.) + (output-case-converter): New function. + (find-matching-symbols): Case convert the symbol-name before + comparing. + (compound-prefix-match, prefix-match-p): Use char= instead of + char-equal. + (case-convert-input): Renamed from case-convert. + (eval-for-emacs): Renamed from eval-string. Take a form instead + of a string. + (dispatch-event, read-from-socket-io): Update callers. + (eval-region, interactive-eval): Use fresh-line to reset the column. + +2004-03-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-space): Send a list of the operator names + surrounding point to Lisp. Lisp can use the list to select the + most suitable arglist for the echo area. Suggested by Christophe + Rhodes and Ivan Boldyrev. + (slime-enclosing-operator-names): New function. + + * swank.lisp (arglist-for-echo-area): Renamed from arglist-string. + (format-arglist-for-echo-area, arglist-to-string): New functions. + +2004-03-12 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-backend.lisp (find-definitions): Fix docstring. + + * slime.el (slime-dispatch-event): Re-enable :ed command. + (sldb-return-from-frame): Send swank:sldb-return-from-frame. + + * swank-cmucl.lisp (find-definitions): Allow names like (setf car). + + * swank.lisp (sldb-return-from-frame): Convert the string to a + sexp. + (dispatch-event, send-to-socket-io): Allow %apply events. + (safe-condition-message): Bind *pretty-print* to t. + (set-default-directory): Use the truename. + (find-definitions-for-emacs): Allow names like (setf car). + +2004-03-12 Wolfgang Jenkner <wjenkner(a)inode.at> + + * swank.lisp (:swank): Export startup-multiprocessing, + restart-frame, return-from-frame. + What about kill-thread and interrupt-thread, which are accessed + as internal symbols? + +2004-03-10 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-cmucl.lisp (struct-definitions, find-dd) + (type-definitions, function-info-definitions) + (source-transform-definitions, setf-definitions): New funtions. + (find-definitions): Include struct definitions, deftypes, setf + defintions, compiler-macros and compiler transforms. + +2004-03-10 Andras Simon <andras(a)renyi.hu> + + * swank.lisp (print-arglist): Use with-standard-io-syntax. + +2004-03-10 Pawel Ostrowski <pasza(a)zodiac.mimuw.edu.pl> + + * swank-cmucl.lisp (unprofile-all): (eval '(profile:unprofile)) + instead of just calling it since it is a macro in cmucl. + + * swank.lisp (:swank): export profile symbols (profiled-functions, + profile-report, profile-reset, unprofile-all, profile-package) + +2004-03-10 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-allegro.lisp, swank-lispworks.lisp, swank-sbcl.lisp, + swank-clisp.lisp, swank-cmucl.lisp (find-definitions): Some + tweaking. + + * swank.lisp (print-arglist): Bind *pretty-circle* to nil to avoid + output like "(function . (cons))". Suggested by Michael Livshin. + (test-print-arglist): Re-enable the tests. + (find-definitions-for-emacs): Renamed from + find-function-locations. + + * slime.el (slime-edit-definition): Renamed from + slime-edit-fdefinition. Display the dspec if there are multiple + definitions. + (slime-symbol-name-at-point): Handle the case when there is no + symbol at point. + (slime-expected-failures): New function + (slime-execute-tests): Use it. + +2004-03-09 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp (frame-source-location-for-emacs): Export it. + Reported by Jouni K Seppanen + (test-print-arglist): Disable the tests until we know what's wrong + with print-arglist. Reported by Michael Livshin. + + * swank-source-path-parser.lisp, swank-gray.lisp (in-package): We + are in-package :swank-backend. Thanks to Raymond Wiker. + + Merge package-split branch into main trunk. + + * swank-clisp.lisp (find-fspec-location): Handle "No such file" + errors. + + * swank-openmcl.lisp (preferred-communication-style): Implemented. + (call-without-interrupts, getpid): Use defimplementation. + (arglist, swank-compile-file, swank-compile-string) + (swank-compile-system, backtrace): Renamed. + (print-frame): New function. + (frame-catch-tags): Don't exclude nil source location. + (format-restarts-for-emacs, debugger-info-for-emacs, + inspect-in-frame). deleted + (frame-arguments): Don't use to-string. + (find-source-locations, find-function-locations + (method-source-location): Deleted. + (canonicalize-location, find-definitions, + function-source-location, list-callers): Use + ccl::edit-definition-p and + ccl::get-source-files-with-types&classes. Makes things easier. + (return-from-frame): Take a sexp not a string. + (describe-definition): Describe more types. + + * swank-loader.lisp: Change load order. swank.lisp is now the last + file. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-gray.lisp, swank-lispworks.lisp, swank-sbcl.lisp, + swank-source-path-parser.lisp: Implement changed backend interface + and remove references to frontend symbols. + + * swank-backend.lisp (:swank-backend): New package. + (definterface): Export the symbol. + (:location, :error, :position, :buffer): Define structure of + source locations here. + (preferred-communication-style, compute-backtrace, print-frame): + New functions. + (debugger-info-for-emacs): Deleted. + + Renaming: + + compile-file-for-emacs -> swank-compile-file + compile-string-for-emacs -> swank-compile-string + compile-system-for-emacs -> swank-compile-stystem + arglist-string -> arglist + backrace -> compute-backtrace + find-function-locations -> find-definitions + + * swank.lisp (:swank): Create the package here. + (*swank-in-background*): Call the backend function + preferred-communication-style to for the initial value. + (find-symbol-designator): Handle NIL properly. + (arglist-string): Renamed from format-arglist. Call backend + function directly. + (*sldb-restarts*, swank-debugger-hook, format-restarts-for-emacs) + (nth-restart, invoke-nth-restart, sldb-abort): Handle restarts in + the front end. + (frame-for-emacs): Renamed from print-with-frame-label. + (backtrace, debugger-info-for-emacs, pprint-eval-string-in-frame) + (set-default-directory): Now in the front end. + (frame-locals-for-emacs): Use print not princ for variable names. + (compile-file-for-emacs, compile-string-for-emacs): Small wrappers + around backend functions. + (describe-definition-for-emacs): Handle unknown symbols before + calling the backend. + (find-function-locations): Wrapper for new backend function + find-definitions. + (group-xrefs, partition, location-valid-p, xref-buffer, xref): + Updated for the new backend functions. + + * slime.el: + (slime-symbol-at-point, slime-symbol-name-at-point): + slime-symbol-at-point calls slime-symbol-name-at-point not the + other way around. This avoids the mess if the symbol at point is + NIL. + (slime-compile-file, slime-load-system, slime-compile-region) + (slime-call-describer, slime-who-calls, sldb-catch-tags): Updates + for renamed lisp functions. + (slime-list-callers, slime-list-callees): Unified with other xref + commands. + (sldb-show-frame-details): Catch tags no longer include the source + location. + (sldb-insert-locals): Simplified. + +2004-03-09 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-cmucl.lisp (read-into-simple-string): Use the correct fix. + Reported by H�kon Alstadheim. + +2004-03-08 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-start-swank-server, slime-maybe-start-lisp): + Translate filenames. Reported by Dan Muller. + +2004-03-08 Bill Clementson <Bill_Clementson(a)peoplesoft.com> + + * slime.el (slime-insert-balanced-comments) + (slime-remove-balanced-comments, slime-pretty-lambdas): New + functions. + +2004-03-07 Jouni K Seppanen <jks(a)iki.fi> + + * slime.el (sldb-help-summary): New function. + (sldb-mode): Add docstring so that describe-mode is useful. + (sldb-mode-map): Add bindings for sldb-help-summary and + describe-mode. + (define-sldb-invoke-restart-key): Generate docstrings. + (sldb-default-action/mouse, sldb-default-action) + (sldb-eval-in-frame, sldb-pprint-eval-in-frame) + (sldb-inspect-in-frame, sldb-down, sldb-up, sldb-details-up) + (sldb-details-down, sldb-list-locals, sldb-quit, sldb-continue) + (sldb-abort, sldb-invoke-restart, sldb-break-with-default-debugger) + (sldb-step): Add rudimentary docstrings. + +2004-03-07 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-complete-symbol*, slime-simple-complete-symbol): + Use the correct block name when returning. + (slime-display-completion-list): Fix typo. + + * swank-cmucl.lisp (frame-locals): Use #:not-available instead of + "<not-available>". + +2004-03-05 Bill Clementson <Bill_Clementson(a)peoplesoft.com> + + * swank-lispworks.lisp (getpid, emacs-connected): Conditionalize + for Windows. + +2004-03-05 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp (frame-locals-for-emacs): Bind *print-readably* to + nil. + +2004-03-05 Marco Baringer <mb(a)bese.it> + + * swank.lisp (frame-locals-for-emacs): New function. + + * slime.el (sldb-frame-locals): Use swank::frame-locals-for-emacs + not swank::frame-locals. + (sldb-insert-locals): use the :value property, not the + :value-string property. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-lispworks.lisp, swank-sbcl.lisp (frame-locals): Return lisp + objects, not strings. Use the :value property and not the + :value-string property. + +2004-03-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-display-comletion-list): New function. Set + syntax table properly. + (slime-complete-symbol*, slime-simple-complete-symbol): Use it. + (slime-update-connection-list): New function. + (slime-draw-connection-list): Simplified. + (slime-connection-list-mode-map): Bind g to update-connection-list. + (slime-open-inspector): Print the primitive type in brackets. + (slime-test-arglist): Add test for empty arglist. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-lispworks.lisp, swank-sbcl.lisp, swank-backend.lisp + (thread-alive-p): Add default implementation. + (describe-primitive-type): Add default implementation. + (inspected-parts): Implemented for Allegro and CLISP. + + * swank.lisp (remove-dead-threads): New function. + (lookup-thread): Use it. + (print-arglist): New function. This time without a custom pretty + print dispatch table. + (format-arglist): Use it. + (inspected-parts): Add method for hash-tables. + +2004-03-03 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp: Use *emacs-connection*, *active-threads*, and + *thread-counter* as thread local dynamic variables. + (init-emacs-connection): Don't set *emacs-connection*. + (create-connection, dispatch-event): Pass the connection object to + newly created threads. + (with-connection): New macro + (handle-request, install-fd-handler, debug-thread): Use it. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-openmcl.lisp, swank-sbcl.lisp (call-with-compilation-hooks): + Bind fewer variables. Most of them are already bound in + swank.lisp. + + * swank.lisp (setup-server, serve-connection): New dont-close + argument to keep the socket open after the first connection. + (start-server, create-swank-server): Update callers. + Reported by Bill Clementson. + + * swank-cmucl.lisp (resolve-note-location): Don't be too clever, + if there is no context available. The compiler notes buffer is + probably more adequate in this situation. + (compile-file-for-emacs): Use the :load argument to compile-file. + (inspect-in-frame): Deleted. + + * slime.el (slime-compilation-finished-hook): Use + slime-maybe-list-compiler-notes as default. + (slime-maybe-list-compiler-notes): New function. + (slime-list-compiler-notes): Insert "[no notes]" if there aren't + any. Pop to the buffer. + (slime-complete-symbol*, slime-simple-complete-symbol): Set the + lisp-mode-syntax-table in the completion buffer. + (check-parens): Compatibility function for XEmacs and Emacs 20. + + * swank.lisp (find-completions): Deleted. + (simple-completions): Use longest-common-prefix instead of + longest-completion. + (inspect-in-frame): Moved here from swank-cmucl.lisp. + + * swank-lispworks.lisp (call-with-debugging-environment): Bind + *sldb-top-frame*. + (nth-frame): Use *sldb-top-frame*. + (name-source-location, name-source-locations): Renamed from + dspec-source-location, dspec-source-locations. The result now + includes methods for generic functions. + (eval-in-frame, return-from-frame, restart-frame): Implemented. + (compile-string-for-emacs): Set dspec::*location* to the buffer + location. + (signal-undefined-functions, signal-error-data-base) + (make-dspec-location): Remove temp-file kludges. + (patch-source-locations, replace-source-file): Deleted. + +2004-03-01 Marco Baringer <mb(a)bese.it> + + * swank.lisp (format-arglist): deal with nil arglists. + +2004-03-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-lispworks.lisp (compile-string-for-emacs): Patch the + recorded source locations. + (replace-source-file, patch-source-locations): New function. + (dspec-buffer-position): Handle defgeneric. + (make-dspec-location): Handle (patched) emacs-buffer locations. + (emacs-buffer-location-p): New function. + (describe-primitive-type, inspected-parts): Implemented. + (kill-thread): Implemented. + + * swank-sbcl.lisp, swank-cmucl.lisp, swank-allegro.lisp + (kill-thread): Implemented. + +2004-02-29 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-complete-symbol): Make slime-complete-symbol + customizable. I don't understand how the ILISP style completion + is supposed to work and find it unintuitive. + (slime-complete-symbol-function): New variable. + (slime-complete-symbol*): Renamed from slime-complete-symbol. + (slime-simple-complete-symbol, slime-simple-completions): New + function. + (slime-compiler-notes-to-tree): Return a list of trees, not a single + tree. + + * swank.lisp (format-arglist): Don't use a custom pprint table. + Didn't work with CLISP and the behavior was different in SBCL and + Lispworks. + (completions): Factorize. + (parse-completion-arguments, format-completion-set, + (completion-set, find-matching-symbols, find-completions): New + functions. + (simple-completions): New function. + (prefix-match-p) New function. + +2004-02-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-compilation-finished-hook): New hook variable. + (slime-compilation-finished): Call it. + (slime-maybe-show-xrefs-for-notes): New function. + (slime-make-default-connection): Use the current connection. + (slime-connection-at-point): New function. + (slime-goto-connection, slime-connection-list-make-default): Use + it. + (slime-draw-connection-list): Minor cleanups. + + Define selectors for t and c for thread and connection list. + + * swank.lisp: (*initial-pprint-dispatch-table*) + (*arglist-pprint-dispatch-table*): Workaround for bug in + CLISP. Don't supply nil as argument to copy-pprint-dispatch. + (print-cons-argument): Insert a space after the car. + +2004-02-27 Marco Baringer <mb(a)bese.it> + + * slime.el (slime-read-port-and-connect, + slime-read-port-and-connect-to-running-swank): Refactor + slime-read-port-and-connect into two functions so that + slime-thread-attach can use the logic in + slime-read-port-and-connect. + (slime-thread-control-mode-map): Added key bindings for + slime-thread-kill, slime-thread-attach, slime-thread-debug and + slime-list-threads. + (slime-thread-kill, slime-thread-attach, slime-thread-debug): New + functions. + + * swank-backend.lisp (kill-thread): Added to swank interface. + + * swank-openmcl.lisp (kill-thread): Implement. + + * swank.lisp (start-server): Add optional background argument, + defaults to *swank-background*. + (lookup-thread-by-id): New function. + (debug-thread): New function. + +2004-02-26 Peter Seibel <peter(a)javamonkey.com> + + * slime.el (slime-draw-connection-list): Use text-properties to + associate the connections each line of the connections list + buffer. + +2004-02-26 Peter Seibel <peter(a)javamonkey.com> + + * slime.el (slime-list-connections): Make the buffer created by + this function do a bit more: Can use it to switch to different + connections and change the default. + +2004-02-26 Marco Baringer <mb(a)bese.it> + + * swank-openmcl.lisp (ccl::force-break-in-listener): Pass a + condition object to invoke-debugger. + Patch by Bryan O'Connor <bryan-slime(a)lunch.org> + +2004-02-26 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-backend.lisp (:swank): export connection-info. + + * swank-allegro.lisp (lisp-implementation-type-name): Implement + it. + + * swank-sbcl.lisp (compile-file-for-emacs): Load the fasl file + regardless of f-p. + + * swank.lisp (swank-pprint): Bind *package* to *buffer-package*. + Reported by Alan Picard. + + * swank-lispworks.lisp (dspec-buffer-position): Renamed from + dspec-buffer-buffer-position. Handle dspecs of the form (defmacro + foo). Reported by Alan Picard. + (arglist-string): Handle unknown arglists properly. + +2004-02-25 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-cmucl.lisp (arglist-string): Delay the call to + di::function-debug-function until it is actually needed. + (compile-file-for-emacs): Load the fasl file irrespective of + COMILE-FILE's third return value. + + * swank.lisp (connection-info): New function. + (open-streams): Don't send the :check-protocol-version message. Now + handled with CONNECTION-INFO. + + * slime.el (slime-symbol-at-point): Don't skip backwards across + whitespace when we are at the first character of a symbol. To + handle this case: skip symbol constituents forward before skipping + whitespace backwards. Reported by Jan Richter. + (slime-connection-close-hook, slime-next-connection) + (slime-make-default-connection): Remove extra call to format. + (slime-init-connection-state): Use only a single RPC instead of 4. + +2004-02-25 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-with-chosen-connection): Bind + slime-dispatching-connection and not slime-buffer-connection. + slime-buffer-connection is a buffer local variable not a dynamic + variable. + (slime-find-connection-by-type-name) + (slime-read-lisp-implementation-type-name): Were lost during the + merge. + (sldb-fetch-more-frames): Use (goto-char (point-max)) instead of + end-of-buffer. + +2004-02-25 Peter Seibel <peter(a)javamonkey.com> + + * slime.el: Various bits of support for maintaining multiple SLIME + connections to different Lisp implementations simultaneously. + + * swank-backend.lisp (lisp-implementation-type-name): Add function to + return simple name of lisp implementation; used by new + multi-connection functionality in slime.el. + +2004-02-25 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp (format-arglist): Use a special pprint-dispatch table. + +2004-02-22 Lawrence Mitchell <wence(a)gmx.li> + + * swank.lisp (format-arglist): Bind *PRINT-PRETTY* to NIL. + (eval-in-emacs): Fix typo in docstring. + + * swank-cmucl.lisp (arglist-string): Bind *PRINT-PRETTY* to NIL. + +2004-02-21 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + Add support for SERVE-EVENT based communication. + + * swank-sbcl.lisp (add-sigio-handler, remove-sigio-handlers): + Renamed. + (add-fd-handler, remove-fd-handlers): Implement interface. + + * swank-cmucl.lisp (fcntl): New function. + (add-sigio-handler, remove-sigio-handlers): Renamed. + (add-fd-handler, remove-fd-handlers): Implement interface. + + * swank.lisp (create-connection): Add support for fd-handlers. + (install-fd-handler, deinstall-fd-handler): New functions. + + * swank-backend.lisp (add-sigio-handler): Renamed from + add-input-handler. + (remove-sigio-handlers): Renamed from remove-input-handlers. + (add-fd-handler, remove-fd-handlers): New interface functions. + + * slime.el (slime-batch-test): Use sit-for instead of + accept-process-output, so that we see something when swank gets + compiled. May be problematic in real batch mode. + (loop-interrupt-continue-interrupt-quit): Wait a second before + interrupting. The signal seems to arrive before the evaluation + request if don't wait => the endless loop is executed inside the + debugger and sldb-quit will not be processed with fd-handlers. + + * swank.lisp (process-available-input): Move auxiliary function to + toplevel. Test if the stream is open. + (install-sigio-handler): Handle the first request after installing + the signal handler. + + * slime.el (slime-keys): Bind C-c C-x t to slime-list-threads and + C-c C-x c to slime-list-connections. + (slime): Disconnect before reconnecting if the inferior-lisp + buffer wasn't renamed. + (slime-connect): Use the host argument and not "localhost". + (slime-compilation-finished): Undo last change. Switch to the + buffer to remove old annotations. + (slime-choose-overlay-region): Ignore errors in + slime-forward-sexp. + +2004-02-18 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime): Just close the connection when called without + prefix-argument. Keeping the connection open doesn't make sense. + We could ask if the Lisp process should be killed, though. + (slime-maybe-close-old-connections): Delete unused function. + (slime-start-swank-server): Use comint-send-string instead of + comint-proc-query, 'cause I don't like Olin "100%" Shivers' code. + (slime-init-output-buffer): Show some animations. + (slime-repl-clear-output): Fixed. + (slime-compilation-finished): It's not necessary to switch to the + original buffer, because the buffer is encoded in the + source-locations. + (sldb-show-source): Don't raise an error if the source cannot be + located. Print a message instead, because errors in + process-filters cause a 1 second delay. + + * swank-cmucl.lisp (read-into-simple-string): Workaround for + read-sequence bug in 18e. + +2004-02-18 Peter Seibel <peter(a)javamonkey.com> + + * swank-loader.lisp: Place the fasl files of different + implementations in different directories. + +2004-02-18 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-clisp.lisp: Update comments about metering package. + + * metering.lisp: Imported from CLOCC. Suggested by Peter Seibel. + +2004-02-17 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp, slime.el (make-compiler-note): Don't send the + short-message across the wire if the slot is nil. + + * swank-cmucl.lisp (clear-xref-info): Compare the truenames with + equalp instead of the unix-truenames. The old version was very + inefficient (clearing the tables with about 1000 entries required + serveral seconds). + (xref-context-derived-from-p, pathname=): Delete unused functions. + + * swank-clisp.lisp (remove-input-handlers): + socket:socket-stream-handle is not available on Windows. + Reported by Alan Shutko. + + * slime.el (slime-length>): New function. + (slime-compiler-notes-to-tree): Don't collapse if there is only + one kind of notes. + +2004-02-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp (make-compiler-note): Include short-message. + + * swank-sbcl.lisp (signal-compiler-condition): Initialize + short-message slot. + (long-compiler-message-for-emacs): New function. + + * swank-cmucl.lisp (handle-notification-condition): Don't use the + context of the previous message. + (signal-compiler-condition): Set short message slot. + (long-compiler-message-for-emacs): New function. + (sigio-handler): Ignore arguments. + + * swank-clisp.lisp (set-sigio-handler, add-input-handler): + Conditionalize for linux. + + * swank-backend.lisp (compile-system-for-emacs): Add default + implementation. + (compiler-condition): New slot short-message. + + * slime.el (slime-compilation-finished): Display compiler notes + grouped by severity in a separate buffer. + (slime-compilation-finished-continuation, slime-compile-file) + (slime-load-system, slime-compile-string): Update callers. + (slime-list-compiler-notes, slime-alistify, slime-tree-for-note) + (slime-tree-for-severity, slime-compiler-notes-to-tree) + (slime-compiler-notes-mode, slime-compiler-notes-quit): New + functions. + (with-struct, slime-tree): New code for pseudo tree widget. + (slime-init-connection-state): Set slime-state-name to "". + +2004-02-08 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-cmucl.lisp (create-socket): Fix last fix. Use the proper + port argument. + + * swank-allegro.lisp, swank-backend.lisp, swank-clisp.lisp, + swank-cmucl.lisp, swank-lispworks.lisp, swank-openmcl.lisp, + swank-sbcl.lisp (create-socket): Take interface as argument. + + * slime.el (sldb-show-frame-details): Fix typos. + (slime-print-apropos): Don't bind action. + (slime-reset): Kill sldb-buffers. + (slime-test-find-definition, slime-test-complete-symbol) + (slime-test-arglist): Add more slime-check-top-level calls. + + * swank.lisp (setup-server): Pass loopback-interface to + create-socket. Reported by Dirk Gerrits. + (*loopback-interface*): New parameter. + (sldb-loop): Send :debug event inside unwind-protect, so we never + lose the corresponding :debug-return event. + +2004-02-08 Marco Baringer <mb(a)bese.it> + + * swank-openmcl.lisp (find-source-locations): Eliminate unused + variable warning. + + * swank.lisp (swank-pprint): Bind pretty print vars to + *swank-pprint-X* counter parts. + (*swank-pprint-circle*, *swank-pprint-escape*, + *swank-pprint-level*, *swank-pprint-length*): Swank counterparts + to *print-X* variables used when swank needs to pretty print a + form. + (apply-macro-expander): Use swank-pprint. + +2004-02-07 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-cmucl.lisp (send, receive, interrupt-thread): Implement + more threading functions. + + * swank-sbcl.lisp (inspected-parts): Implemented. + + * slime.el (slime-rex): Mention thread argument in docstring. + (sldb-break-with-default-debugger): Use slime-rex and don't switch + to the output buffer (happens automatically). + (slime-list-threads): Renamed from slime-thread-control-panel. + (slime-thread-insert): Use slightly different layout. + (slime-give-goahead, slime-waiting-threads) + (slime-popup-thread-control-panel, slime-register-waiting-thread) + (slime-thread-goahead): Deleted. + (slime-maybe-start-multiprocessing): Call + swank:startup-multiprocessing. Reported by Paolo Amoroso. + + * swank.lisp (dispatch-event): :debug, :debug-condition, + :debug-activate events were all encoded as :debug events, which + means the debugger never worked! Fix it. I guess no one uses + SLIME with a multithreaded Lisp. + (read-user-input-from-emacs): Flush the output before reading. + (sldb-loop): Add a sldb-enter-default-debugger tag, so we can + enter the default debugger by throwing to it. + (sldb-break-with-default-debugger): Throw to + sldb-enter-default-debugger. + (*thread-list*): New variable. + (list-threads): New function. + + * swank-backend.lisp (thread-name): Take a thread object as + argument. + (thread-status, all-threads, thread-alive-p): New function. + (thread-id): Deleted. + + * swank-allegro.lisp, swank-cmucl.lisp, swank-lispworks.lisp, + swank-openmcl.lisp, swank-sbcl.lisp: Update for modified thread + interface. + + * swank-sbcl.lisp (enable-sigio-on-fd): New function. Use + fallback if sb-posix:fcntl isn't fbound. + + * swank-cmucl.lisp (gf-definition-location): Return an error when + pathname for the GF is nil (this happens if the GF is not compiled + from a file). + + * swank.lisp (undefine-function): New function. + (print-with-frame-label, print-part-to-string): Bind + *print-circle* to t, to avoid unbound recursion when printing + cyclic data structures. + + * slime.el (slime-undefine-function): New command. Bound to C-c + C-u. + +2004-02-06 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (sldb-setup): Offer to enter a recursive edit if there + are pending continuations. + (slime-eval): Unwind the stack, thereby exititing recursive edits, + before signaling the error. + +2004-02-05 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-openmcl.lisp (compile-system-for-emacs): Remove compile + time dependency on ASDF. + +2004-02-05 Wolfgang Jenkner <wjenkner(a)inode.at> + + * swank-clisp.lisp, swank-loader.lisp: Add profiling support via + Kantrowitz's metering package. Reporting needs to be + refined (profile-package currently ignores callers-p and methods). + +2004-02-04 Bryan O'Connor <bryan-slime(a)lunch.org> + + * swank-openmcl.lisp (mailbox): Use a semaphore instead of + process-wait. Works better with native threads. + +2004-02-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-backend.lisp (debugger-info-for-emacs): Export it. + + * swank-sbcl.lisp (add-input-handler): Use fcntl from the sb-posix + package. + + * swank.lisp (sldb-loop, dispatch-event, send-to-socket-io): Send + a :debug-activate event instead of a :debug event (to avoid + sending a potentially long backtrace each time). + (handle-sldb-condition): Include the thread-id in the message. + + * slime.el (slime-path): Use load-file-name as fallback. + Suggested by Lawrence Mitchell. + (slime-dispatch-event): Add support for :debug-activate event. + (sldb-activate): New function. + (sldb-mode): make-local-hook doesn't seem to work in Emacs 20. + Use a buffer local variable instead. + (slime-list-connections): Don't print Lisp's state. + (slime-short-state-name): Deleted. + +2004-02-02 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-debugger): The customization group is called + 'slime-debugger', fix referrers. Reported by Jouni K Seppanen. + + * swank.lisp (simple-break): Bind *debugger-hook* before invoking + the debugger. Reported by Michael Livshin. + +2004-01-31 Robert E. Brown <bbrown(a)speakeasy.net> + + * swank-sbcl.lisp, swank.lisp: Add more type declarations and + detect missing initargs for the connection struct. + +2004-01-31 Jouni K Seppanen <jks(a)iki.fi> + + * slime.el (slime-path): Placed inside an eval-and-compile. Works + around some problems when byte-compiling slime-changelog-date. + +2004-01-31 Marco Baringer <mb(a)bese.it> + + * swank-openmcl.lisp: remove defslimefun-unimplemented forms. + (call-with-compilation-hooks, compile-system-for-emacs): Implement + them. + (compile-file-for-emacs, compile-string-for-emacs): Use + with-compilation-hooks. + (list-callers): Define with defimplementation and not defslimefun. + + * swank-backend.lisp (compile-system-for-emacs): Declare method + as part of the interface. + + * slime.el (slime-find-asd): Handle files whose directory does + not contain an asdf system definition. + +2004-01-31 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + Merge stateless-emacs branch into main trunk. We use now signal + driven IO for CMUCL and one thread per request for multithreaded + Lisps. + +2004-01-31 Robert E. Brown <bbrown(a)speakeasy.net> + + * swank-backend.lisp, swank-sbcl.lisp, + swank-source-path-parser.lisp, swank.lisp: Add type declarations + to keep SBCL quiet. + +2004-01-29 Michael Weber <michaelw+slime(a)foldr.org> + + * slime.el, swank-backend.lisp, swank-cmucl.lisp, swank-sbcl.lisp, + swank.lisp: Profiler support. + +2004-01-23 Alan Ruttenberg <alanr-l(a)mumble.net> + + * swank-openmcl.lisp: Bind ccl::*signal-printing-errors* to nil + inside debugger so that error while printing error take us down. + +2004-01-23 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-sbcl.lisp (eval-in-frame, return-from-frame): Implemented. + (sb-debug-catch-tag-p): New auxiliary predicate. + (source-path<): Delete unused function. + +2004-01-23 Michael Weber <michaelw(a)foldr.org> + + * slime.el (slime-keys): Bind C-c M-p to slime-repl-set-package. + (slime-easy-menu): Add entry for slime-repl-set-package. + +2004-01-23 Michael Weber <michaelw(a)foldr.org> + + * slime.el (slime-repl-set-package): New command to set the + package in the REPL buffer. + + * swank.lisp (set-package): Return the shortest nickname. + +2004-01-23 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (sldb-disassemble): Was lost somewhere. + +2004-01-22 Wolfgang Jenkner <wjenkner(a)inode.at> + + * swank-clisp.lisp: Replace defmethod by defimplementation where + appropriate. + (return-from-frame, restart-frame): Implement them. + +2004-01-22 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * test.sh: Copy the ChangeLog file too. + + * swank-cmucl.lisp: Replace some defmethods with + defimplementation. + + * swank-allegro.lisp (return-from-frame, restart-name): Implement + interface (partly). + + * swank-openmcl.lisp (restart-frame, return-from-frame): Remove + sldb-prefix. + + * swank-backend.lisp (return-from-frame, restart-frame): + Are now interface functions. + + * swank.asd: Remove dependency on :sb-bsd-sockets. Is already + done in swank-sbcl. + + * swank-loader.lisp: Don't reference the swank package at + read-time. + + * swank.lisp (completions): Never bind *package* to nil. That's a + type error in SBCL. + (swank-debugger-hook): Flush the output streams and be careful + when accessing *buffer-package*. + (create-swank-server): Return the port of the serve socket. + + * swank-lispworks.lisp (interesting-frame-p): Don't print catch + frames. + (make-sigint-handler): New function. + (emacs-connected): Use it. + + * slime.el (slime-lisp-implementation-type): New per connection + variable. + (slime-handle-oob): Handle debug-condition event. Can be signaled + CMUCL when cannot produce a backtrace. + (slime-debugging-state): Don't pop up the debugger buffer an + activate events. Annoying. + (sldb-break-with-default-debugger): Switch to the output buffer + before returning to the tty-debugger. + (sldb-return-from-frame, sldb-restart-frame): Use slime-rex. + (slime-list-connections, slime-short-state-name): New functions. + +2004-01-20 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-complete-symbol): Insert the completed-prefix + before deleting the original text to avoid troubles with left + inserting markers. + (slime-symbol-start-pos): Skip backward across symbol + constituents. + (slime-evaluating-state): [:read-sring] Save the window + configuration. + (slime-read-string-state): Don't handle activate events + (troublesome if, e.g, complete-symbol is used from another + buffer). Restore the window configuration. + (slime-repl-read-string): Goto the end of buffer. + (slime-debugging-state): [:activate] Display the debugger buffer + if not visible. + (slime-to-lisp-filename, slime-from-lisp-filename) + (slime-translate-to-lisp-filename-function) + (slime-translate-from-lisp-filename-function, slime-compile-file) + (slime-goto-location-buffer, slime-ed, slime-load-file): Support + for remote filename translation (untested). + + * swank.lisp (create-swank-server): Take announce-fn as optional + argument. + + * swank-allegro.lisp: Replace defmethod with defimplementation. + (eval-in-frame): Implemented. + +2004-01-20 Lasse Rasinen <lrasinen(a)iki.fi> + + * slime.el (slime-prin1-to-string): Replacement for + prin1-to-string that avoids escaping non-ascii characters in a + way that the CL reader doesn't understand. Allows use of 8-bit + characters in Lisp expressions with Emacs in unibyte-mode. + +2004-01-20 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-eval-print-last-expression): Insert a newline + before and after the result. + (slime-easy-menu): Added menu items: + "Eval Region", "Scratch Buffer", "Apropos Package..." + Added some bold to default SLDB faces. + +2004-01-19 Alan Ruttenberg <alanr-l(a)mumble.net> + *swank-openmcl.lisp in frame-catch-tags, ppc32::catch-frame.catch-tag-cell -> 0, + ppc32::catch-frame.csp-cell -> 3. FIXME when this code is more stable in openMCL. + +2004-01-19 Michael Weber <michaelw(a)foldr.org> + + * slime.el (slime-close-all-sexp): New command to close all + unmatched parens in the current defun. Bound to `C-c C-]'. With + prefix argument, only operate in the region (for closing + subforms). + +2004-01-19 Luke Gorrie <luke(a)bluetail.com> + + * swank-openmcl.lisp (thread-id, thread-name): Fixed silly bugs + (thanks Marco Baringer). + + * swank-loader.lisp: Call (swank:warn-unimplemented-interfaces). + + * swank.lisp (ed-in-emacs): New command with the same interface + as CL:ED. + + * swank-cmucl.lisp, swank-sbcl.lisp, swank-lispworks.lisp, + swank-openmcl.lisp, swank-allegro.lisp, swank-clisp.lisp: Updated + to use `defimplementation'. + + * swank-backend.lisp (definterface, defimplementation): New macros + as sugar around defgeneric/defmethod. This supports conveniently + supplying a default (on NO-APPLICABLE-METHOD). Because the + underly mechanism is still generic functions this doesn't break + code that isn't updated. + (warn-unimplemented-interfaces): Print a list of backend functions + that are not implemented. + (xref and list-callers): Defined interfaces for these functions. + (describe-definition): New function that takes over from the many + other describe-* functions called from apropos listing. Takes the + type of definition (as returned by describe-symbol-for-emacs) as + an argument. + + * slime.el (sldb-enable-styled-backtrace): This is now true by + default. + (slime-keys): Bound `slime-inspect' to `C-c I'. + (slime): `M-x slime' now offers to keep existing connections + alive (else disconnect them). If you disconnect them, the new + connection gets to reuse the existing REPL. + (slime-connection): Error if the connection is closed. + (slime-handle-oob): New message (:ED WHAT) for `slime-ed'. + (slime-display-output-buffer): Don't pop up the REPL if it is + already visible in any frame. + (slime-find-asd): Handle case where (buffer-file-name) is nil. + (slime-ed): Elisp backend for (CL:ED WHAT). + (slime-apropos): Add a summary line to apropos listings. + (slime-print-apropos): Replaced `action' property (name of lisp + describe function) with `type' (argument to pass to unified + swank:describe-definition function). + (slime-apropos-package): New command on `C-c P'. Presents apropos + listing for all external (with prefix also internal) symbols in a + package. + +2004-01-18 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-lispworks.lisp (sigint-handler): Bind a continue restart. + (make-dspec-location): Handle strings like pathnames. + Some multithreading support. + + * slime.el (compile-defun): Don't use keywords. The keyword + package is locked in Lispworks and causes the test-suite to hang. + (slime-eval-with-transcript): Fix bug triggered when 'package' is + a buffer local variable. Reported by Janis Dzerins. + (slime-batch-test): Wait until the connection is ready. + +2004-01-18 Alan Ruttenberg <alanr-l(a)mumble.net> + + * swank-openmcl: Implement frame-catch-tags. Added debugger functions + sldb-restart-frame, sldb-return-from-frame. Should probably be added to backend.lisp + but let's discuss first. Do other lisps support this? + + * slime.el sldb-restart-frame, sldb-return-from-frame + +2004-01-18 Wolfgang Jenkner <wjenkner(a)inode.at> + + * swank-clisp.lisp (call-without-interrupts): Evaluate + linux:SIGFOO at read time since the macro with-blocked-signals + expects a fixnum. + (compile-file-for-emacs): Comment fix. + +2004-01-18 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-sbcl.lisp (make-fn-streams): Deleted. Already defined in + swank-gray.lisp. + + * swank.lisp (find-symbol-or-lose, format-arglist): New functions. + (without-interrupts): New macro. + (send-to-emacs): Use it. + + * swank-backend.lisp, swank-clisp.lisp, swank-lispworks.lisp, + swank-openmcl.lisp, swank-sbcl.lisp, swank-allegro.lisp: + (arglist-string): Refactor common code to swank.lisp. + (call-without-interrupts, getpid): Are now generic functions. + + * slime.el (arglist): Test slot readers and closures. + + * swank-cmucl.lisp (arglist-string): Use + pcl:generic-function-lambda-list for generic functions. Handle + closures. Print arglist in lower case. + (inspected-parts-of-value-cell): Was lost during the inspector + refactoring. + +2004-01-18 Wolfgang Jenkner <wjenkner(a)inode.at> + + * swank-clisp.lisp (compile-file-for-emacs, + split-compiler-note-line): Revert last change. + (handle-notification-condition): Don't signal the condition. + (*compiler-note-line-regexp*): Fix and rewrite it as extended + regexp. + + * slime.el (slime-changelog-date): Use file-truename of + byte-compile-current-file. + +2004-01-17 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-format-arglist): Add some sanity checks and + print zero argument functions nicer. Suggested by Ivan Boldyrev. + (slime-test-expect): Take test predicate as argument. + (arglist): Test generic functions. + + * swank-cmucl.lisp (arglist-string): Handle generic functions + better. Reported by Ivan Boldyrev. + +2004-01-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-allegro.lisp: Multiprocessing support. + + * swank-openmcl.lisp, swank-cmucl.lisp, swank-backend.lisp, + swank.lisp: Refactor inspector code. + + * swank.lisp (changelog-date): Use *compile-file-truename* instead + of *compile-file-pathname*. + (with-I/O-lock, with-a-connection): The usual CLISP fixes. + (create-swank-server): Patch by Marco Baringer <mb(a)bese.it>. + Bring it back again. + (create-connection): Use return the dedicated output stream if + available. + + * slime.el: Numerous REPL related fixes. + (slime-update-state-name): Take state as argument. + (slime-repl-beginning-of-defun, slime-repl-end-of-defun): Fix + typos. + (sldb-insert-restarts): Remove duplicate definition. + +2004-01-16 Luke Gorrie <luke(a)bluetail.com> + + * swank-openmcl.lisp: Multiprocessing support. + + * swank.lisp (changelog-date): make-pathname portability fix + (from alanr). + (with-io-redirection): Use (current-connection) instead of + *dispatching-connection* (from alanr). + + * slime.el (slime-init-output-buffer): XEmacs portability fix, and + use header-line-format to show info about Lisp in Emacs21. + +2004-01-15 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-sbcl.lisp, swank-cmucl.lisp (remove-input-handlers): New + method. + + * swank-allegro.lisp (excl:stream-read-char-no-hang): Import it. + (emacs-connected): Add default method. The method for + no-applicable-method doesn't seem to work. ACL bug? + + * swank-loader.lisp (compile-files-if-needed-serially): Don't + handle compilation errors. We must compile everything because + changelog-date requires *compile-file-truename*. + + * slime.el: (slime-changelog-date) + (slime-check-protocol-version): New functions. + (slime-handle-oob): Handle :check-protocol-version event. + (slime-init-output-buffer): Print some info about the remote Lisp. + (slime-connect): Use it. + (slime-note-transcript-start): Renamed from + slime-insert-transcript-delimiter. + (slime-note-transcript-end): New function. + (slime-with-output-end-mark, slime-repl-insert-prompt) + (slime-repl-show-result, slime-compile-file) + (slime-show-evaluation-result): Insert output from eval commands + after the prompt and asynchronous output before the prompt. Needs + documentation. + (repl-test, repl-read, interactive-eval-output): New tests. + (slime-flush-output): Accept output from all processes. + + * swank.lisp (serve-requests): New function. + (setup-server): Use it. + (start-server): Pass backgroud to setup-server. + (create-connection): Check the protocol version. + (changelog-date): New function. + (make-output-function): Use write-string instead of princ. + + * swank-backend.lisp (remove-input-handlers): New function. + +2004-01-15 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-aux-connect, slime-handle-oob): Support for + (:open-aux-connection port) message where Lisp requests that + Emacs make a connection. These are "auxiliary" connections which + don't (or at least shouldn't) have their own REPL etc. + + * swank.lisp: New support for multiprocessing and multiple + connections + commentary. + (with-a-connection): Macro to execute some forms "with a + connection". This is used in the debugger hook to automatically + create a temporary connection if needed (i.e. if the current + thread doesn't already have one). + (open-aux-connection): Helper function to create an extra + connection to Emacs. + + * swank-sbcl.lisp: Implemented multiprocessing. Not perfect. + + * swank-cmucl.lisp: Implemented new multiprocessing interface. + (create-socket): Make FDs non-blocking when multiprocessing is + enabled. + (startup-multiprocessing): Set *swank-in-background* to :spawn. + + * swank-backend.lisp: Changed multiprocessing interface. + +2004-01-15 Wolfgang Jenkner <wjenkner(a)inode.at> + + * swank-clisp.lisp (with-blocked-signals): New macro. + (without-interrupts): Use it. + (*use-dedicated-output-stream*, *redirect-output*): Don't set them + here, use the default settings. + Make :linux one of *features* if we find the "LINUX" package. + +2004-01-14 Luke Gorrie <luke(a)bluetail.com> + + * swank-openmcl.lisp (emacs-connected): Typo fix (missing + close-paren). + +2004-01-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-input-complete-p): Tolerate extra close parens. + (slime-idle-state): Don't active the repl. + (slime-insert-transcript-delimiter): Insert output before prompt. + (slime-open-stream-to-lisp): Initialize the process-buffer with + the connection buffer. + (slime-repl-activate): Deleted. + (slime-repl-eval-string, slime-repl-show-result) + (slime-repl-show-abort): Better handling of abortion. + (slime-compile-file): Insert output before prompt. + + * swank-lispworks.lisp (create-socket): Fix condition message. + + * swank-openmcl.lisp (*swank-in-background*): Set to :spawn. + (emacs-connected): Initialize ccl::*interactive-abort-process*. + + * swank.lisp (*swank-in-background*): New variable. + (start-server): Start swank in background, depending on + *swank-in-background*. + + * swank-cmucl.lisp, swank-sbcl.lisp (*swank-in-background*): Set + to :fd-handler. + + * swank-clisp.lisp (accept-connection): Remove superfluous call to + socket-wait. + + New more direct socket interface. The new interface is closer to + the functions provided by the implementations. For Lispworks we + use some non-exported functions to get a sane interface. The + interface also includes add-input-handler and a spawn function + (not used yet). The idea is that most of the logic can be shared + between similar backends. + + * swank-gray.lisp (make-fn-streams): New function. + (stream-read-char-no-hang, stream-read-char-will-hang-p): Moved to + here from swank-clisp.lisp. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp: + (create-socket, local-port, close-socket, accept-connection) + (add-input-handler, spawn): Implement new socket interface. + + * swank.lisp (start-server, open-dedicated-output-stream &etc): + Use new socket functions. + + * swank-backend.lisp (create-socket, local-port, close-socket) + (accept-connection, add-input-handler, spawn): New functions. + (accept-socket/stream, accept-socket/run): Deleted. + +2004-01-13 Luke Gorrie <luke(a)bluetail.com> + + * swank-clisp.lisp: Updated for new network interface but not + tested! Probably slightly broken. + + * swank-lispworks.lisp: Updated for new network interface. + (accept-socket/stream): This function is currently broken, so + LispWorks can't use the dedicated output channel at the moment. + + * swank.lisp, swank-cmucl.lisp, swank-sbcl.lisp: Updated for new + network interface. + + * swank-backend.lisp (accept-socket/stream, accept-socket/run): + New functions replacing the ancient (over 24 hours!) + `create-socket-server'. This interface is much simpler. + +2004-01-12 Luke Gorrie <luke(a)bluetail.com> + + * swank-lispworks.lisp: Partially updated for new backend + interface, but not actually working. The sockets code is broken, I + haven't grokked LispWorks the interface properly. + + * swank-gray.lisp (slime-input-stream, slime-output-buffer): Added + slots to support the new `make-fn-streams' interface from + swank-backend.lisp. These slots need to be initialized by the + backend, see swank-sbcl.lisp for an example (very easy). + + * swank-sbcl.lisp (create-socket-server): Implemented new server + interface. + + * slime.el (slime-handle-oob): Added + :open-dedicated-output-stream message, previously implemented + with :%apply. + (slime-repl-read-string, slime-repl-return-string): Pass integer + argument to `slime-repl-read-mode' to set rather than toggle. + + * swank.lisp: Taking over previously non-portable jobs: + (start-server): Now only uses sockets code from the backend. + (handle-request): Top-level request loop. + (open-dedicated-output-stream): Dedicated output socket. + (connection): New data structure that bundles together the things + that constitute a connection to Emacs: socket-level stream and + user-level redirected streams. + + * swank-cmucl.lisp (create-socket-server): Generic TCP server + driven by SERVE-EVENT. + (serve-one-request, open-stream-to-emacs): Deleted. Now handled + portably in swank.lisp. + (make-fn-streams): Implement new stream-redirection interface. + (slime-input-stream): New slot referencing output sibling, so it + can be forced before input requests. + + * swank-backend.lisp (create-socket-server): Generic + callback-driven TCP server interface. Replaces + `create-swank-server', with the higher-level logic moved into + swank.lisp. + (emacs-connected): Invoked when Emacs initially connects, as a + hook for backend implementations. + (make-fn-streams): Interface for creating pairs of input/output + streams that are backended by callback functions. Used to + implement redirected-via-Emacs standard I/O streams. + +2004-01-12 Lawrence Mitchell <wence(a)gmx.li> + + * slime.el (slime-events-buffer): Set `hs-block-start-regexp' + before running `hs-minor-mode'. + +2004-01-10 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (package-updating): Expected package is now a list (can + be any), since the shortest nickname is not + standardized. e.g. USER or CL-USER for COMMON-LISP-USER. + + * swank-cmucl.lisp: Don't enable xref (let the user decide). + (set-fd-non-blocking): Removed unused function. + Miscellaneous refactoring of the networking code. + + * slime.el (slime-complete-symbol): Use markers to hold the + beginning and end of the completion prefix, in case looking up + completions causes insertions (e.g. GC announcements). + +2004-01-09 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-activate-state): Only update state name when + `slime-default-connection' activates. This fixes an annoying + "Selecting deleted buffer" bug that prevented SLIME from being + restarted. + (slime-next-connection): Fixed a bug where buffer-local connection + bindings could get in the way and prevent the connection from + actually changing. + (slime-complete-restore-window-configuration): Wrap + `set-window-configuration' in `save-excursion'. This fixes a + problem where the cursor would end up in the wrong place after + completion in XEmacs. + +2004-01-09 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: Place (require 'cl) inside a eval-and-compile. + (slime-with-connection-buffer): Move definition upwards before the + first use. + (package-updateing): New test for package updates in the listeners. + + * swank.lisp (eval-region): Bind *package* outside the + unwind-protect to detect updates. + + * swank-backend.lisp (debugger-info-for-emacs) + (find-function-locations): Doc fix. + +2004-01-09 Wolfgang Jenkner <wjenkner(a)inode.at> + + * swank-clisp.lisp: Add methods for GRAY:STREAM-READ-CHAR-NO-HANG + and for the CLISP specific GRAY:STREAM-READ-CHAR-WILL-HANG-P. + This should fix the behaviour of SYS::READ-FORM. + +2004-01-08 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-inspector-fontify): Function to insert a string + in a particular inspector face. Replaces macro-code-generation + function `slime-inspector-expand-fontify'. Fixes a byte-compile + problem (macro was calling function not defined at compile-time). + +2004-01-07 Luke Gorrie <luke(a)bluetail.com> + + * slime.el: Multisession internal improvements. Now there are + three separate connection variables, in order of priority: + slime-dispatching-connection (dynamically-bound) + slime-buffer-connection (buffer-local) + slime-default-connection (global) + The most specific one available is used. This is splitting + `slime-connection' into multiple variables, so that you can be + specific about what you want to assign (i.e. know if you're + setting a dynamic binding or a buffer-local one). + Fixed some related bugs. + (slime-connection-close-hook): If default connection closes, + select another connection. + (slime-lisp-package): Initially CL-USER nickname instead of + COMMON-LISP-USER (for REPL prompt). + + * slime.el (slime): Multisession support: with prefix argument, + gives the option of keeping existing sessions and firing up an + additional *inferior-lisp* to connect to. Each connection now has + its own *slime-repl[<n>]* buffer. + (slime-connection): Should now be read via the function of the + same name. The accessor will check if the value is NIL, and if so + use `slime-default-connection'. + (slime-default-connection): The connection that will be used by + default, i.e. unless `slime-connection' is bound. Renamed from + `slime-primary-connection'. + (slime-init-connection-state): When reconnecting, update the + `slime-connection' binding in the REPL to use the new connection. + (slime-repl-input-history, ...): REPL variables are now + buffer-local. + +2004-01-06 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp (eval-string): New argument 'id'. Used to identify + the remote continuation. + (log-event): New debugging function. + (read-from-emacs, send-to-emacs): Use it. + + * slime.el: The new macro 'slime-rex' can now be used to evaluate + sexps remotely. It offers finer control what to do when the + evaluation aborts. + (slime-rex): New macro + (slime-eval, slime-eval-async, sldb-continue) + (sldb-invoke-restart): Use it. + (slime-continuation-counter, slime-push-evaluating-state): New + functions. + (slime-output-buffer): Initialize markers. + (sldb-mode): XEmacs doesn't like (add-hook (make-local-hook ...)). + (slime-init-connection): New optional argument SELECT. + (slime-def-connection-var): Workarounds for Emacs 20 reader bugs. + Backquote is pretty broken Emacs 20. + +2004-01-06 Ignas Mikalajunas <i.mikalajunas(a)mbt.lt> + + * swank-loader.lisp (user-init-file): Use merge-pathames. Fix + Windows support. + +2004-01-05 Luke Gorrie <luke(a)bluetail.com> + + * slime.el: Multiple session support, i.e. Emacs can open + multiple connections to Lisps. The guts is there, but + user-interface is currently minimal. + (slime-net-process): Replaced with slime-net-processes. + (slime-net-send): Take process as argument. + (slime-process-available-input): Poll all connections. + (slime-connection): Current connection (process) to use for + talking to Lisp. Can be bound dynamically or buffer-local. + (slime-with-connection-buffer): Macro to enter the process-buffer + of `slime-connection' to manipulate the local variables. + (slime-stack-stack): Now buffer-local in the process-buffer of + each connection. + (slime-push-state, slime-pop-state): Operate on the stack inside + `slime-connection's process-buffer. + (slime-dispatch-event): Take optional process argument, to bind + `slime-connection' appropriately when events arrive from the + network. + (slime-def-connection-var): Macro to define variables that are + "connection-local". Such variables are used via (setf'able) + accessor functions, and their real bindings exist as local + variables in the process-buffers of connections. The accessors + automatically work on `slime-connection'. + (slime-lisp-features, slime-lisp-package, slime-pid, sldb-level): + These variables are now connection-local. + (slime-read-from-minibuffer): Inherit `slime-connection' as + buffer-local so that we complete towards the right Lisp. + (sldb-mode): Inherit `slime-connection' as buffer-local so that we + debug towards the right Lisp. + (get-sldb-buffer): New function to return (optionally create) the + SLDB buffer for the current connection. Since multiple Lisps can + be debugged simultaneously, the buffername now includes the + connection number. + (slime-connection-abort): New command to abort a connection + attempt (don't use `slime-disconnect' anymore - that closes all + connections). + (slime-execute-tests): Honor `slime-test-debug-on-error'. + (slime-next-connection): Cycle through open Lisp connections. + +2004-01-02 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-display-output-buffer): Move the output markers + to the end of the buffer. + + * swank-clisp.lisp (frame-do-venv): Rename the :symbol property to + :name. + (format-condition-for-emacs): Replaced with + debugger-condition-for-emacs. + (backtrace): Use print-with-frame-label. + + * swank-openmcl.lisp (format-condition-for-emacs): Replaced with + debugger-condition-for-emacs. + (backtrace): Use print-with-frame-label. + (frame-locals): Rename the :symbol property to :name. + + * swank-lispworks.lisp (format-condition-for-emacs): Replaced with + debugger-condition-for-emacs. + (backtrace): Use print-with-frame-label. + (frame-locals): Rename the :symbol property to :name. + + * swank-allegro.lisp (frame-locals): Rename the :symbol property + to :name. + (format-condition-for-emacs): Replaced with + debugger-condition-for-emacs. + (backtrace): Use print-with-frame-label. + + * swank-sbcl.lisp (tracedp, toggle-trace-fdefinition) + (format-condition-for-emacs): Remove unused functions. + (format-frame-for-emacs): Use print-with-frame-label. + (compute-backtrace): Simplified. + (backtrace): Return our frame numbers. + (frame-locals): Rename the :symbol property to :name. Remove the + :validity property. + + * swank-cmucl.lisp (accept-loop, safe-definition-finding): Doc + fix. + (location-buffer=, file-xrefs-for-emacs) + (sort-contexts-by-source-path, source-path<) + (format-condition-for-emacs): Remove unused functions. + (format-frame-for-emacs): Don't include the frame number in the + description, but use the frame number for indentation. Update + callers. + (frame-locals): Rename the :symbol property to :name. + + * slime.el (slime-add-face): New function. + (sldb-add-face): Use it. + (sldb-setup): Some refactoring. + (sldb-insert-condition): New function. Factorized from + sldb-setup. Message and types are now separate. + (sldb-insert-restarts): New function. Factorized from sldb-setup. + (sldb-insert-frame): Factorized from slime-insert-frames. The + frame number in no longer part of the string describing the frame. + (sldb-insert-frames): Use it. + (sldb-show-frame-details): Print frame numbers. Fix printing of + catch tags. Move to the start of the frame before at the + beginning to get unfontified text properties. + (sldb-inspect-condition): New command. + (sldb-insert-locals): The :symbol property is now called :name. + Fix locals with :id attribute. + (slime-open-inspector): Fix the bugs I introduced last time. + + * swank.lisp (safe-condition-message): New function. + (debugger-condition-for-emacs): Used to be + format-condition-for-emacs in each backend. Separate the + condition message from the type description. Update all backends + accordingly. + (print-with-frame-label): New function. + + * slime.el (slime-hyperspec-lookup): New function. + +2004-01-02 Wolfgang Jenkner <wjenkner(a)inode.at> + + * swank-clisp.lisp: New file. Merged with Vladimir's version. + + * xref.lisp: New file. Used by swank-clisp. + + * swank-loader.lisp (user-init-file): Add CLISP files. + + * swank.lisp (eval-region, tokenize-completion): Modify loops a + bit to make CLISP happy. + + * swank-backend.lisp (with-compilation-hooks): Replace () with + (&rest _) to make CLISP happy. + + * slime.el (slime-goto-source-location): Support for CLISP style + line numbers. Split it up. + (slime-goto-location-buffer, slime-goto-location-position): New + functions. + (slime-load-system): Use slime-display-output-buffer. + (slime-repl-mode): Disable conservative scrolling. Not sure if it + was a good idea. + (sldb-insert-frames, sldb-show-frame-details, sldb-list-locals): + Minor fixes. + (sldb-insert-locals): Renamed from sldb-princ-locals. + (sldb-invoke-restart): Use slime-eval instead of + slime-oneway-eval, because interactive restarts may read input. + (slime-open-inspector): Minor indentation fixes. + (slime-net-output-funcall): Removed. Was unused. + +2003-12-19 Alan Ruttenberg <alanr-l(a)mumble.net> + * slime.el 1.157 + fix bug in sldb-princ-locals I introduced when adding fonts to sldb + +2003-12-19 Alan Ruttenberg <alanr-l(a)mumble.net> + * swank-openmcl.lisp 1.42 + in request-loop register output stream to be periodically slushed per Gary Byer's email. + * slime.el 1.156 + slime-goto-source-location. Sometimes source information is recorded but it isn't a standard "def" + in that case, don't error out, just look for the most likely place for the definition. + +2003-12-19 Luke Gorrie <luke(a)bluetail.com> + + * null-swank-impl.lisp: Deleted this old file. See + swank-backend.lisp instead. + +2003-12-18 Alan Ruttenberg <alanr-l(a)mumble.net> + * swank-openmcl.lisp 1.41 + in openmcl (break) now goes into slime debugger. + (setq swank:*break-in-sldb* nil) to disable that. + +2003-12-17 Alan Ruttenberg <alanr-l(a)mumble.net> + * slime.el 1.155 + Allow font choices for backtrack. Add group for customizing them: sldb. + Whole thing is enabled with sldb-enable-styled-backtrace which is off by default, for now. + Try + '(sldb-condition-face ((t (:foreground "DarkSlateGray" :weight bold)))) + '(sldb-detailed-frame-line-face ((t (:foreground "brown" :weight bold :height 1.2)))) + '(sldb-local-name-face ((t (:weight bold)))) + '(sldb-restart-face ((t (:foreground "DarkBlue" :weight bold)))) + '(sldb-restart-number-face ((t (:underline t :weight bold)))) + '(sldb-restart-type-face ((t (:foreground "DarkSlateGrey" :weight bold)))) + '(sldb-section-face ((t (:weight bold :height 1.2)))) + '(sldb-selected-frame-line-face ((t (:foreground "brown" :weight bold :height 1.2)))) + '(sldb-topline-face ((t (:foreground "brown" :weight bold :height 1.2)))) + +2003-12-17 Alan Ruttenberg <alanr-l(a)mumble.net> + * slime.el 1.154 + Allow some face choices in the inspector. Try + '(slime-inspector-label-face ((t (:weight bold)))) + '(slime-inspector-topline-face ((t (:foreground "brown" :weight bold :height 1.2)))) + '(slime-inspector-type-face ((t (:foreground "DarkRed" :weight bold)))) + You can also set slime-inspector-value-face + +2003-12-17 Alan Ruttenberg <alanr-l(a)mumble.net> + + * swank-openmcl.lisp 1.40 + Fix an error with frame-source-location-for-emacs when the + function was a method-function. + Defined method-source-location that handles this case. You can + still end up looking at the wrong definition, as the protocol + doesn't allow passing back the qualifiers and specializers to look + up the correct one in the file + +. * swank-openmcl.lisp 1.39 + Allow you to continue after interrupting. + Properly set *swank-debugger-stack-frame* when interrupting. + + * slime.el 1.152 + sldb-continue now uses slime-oneway-eval + +2003-12-17 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: Better handling of asynchronous output. + (slime-output-end): New variable. Use this marker to insert + output. Insert asynchronous output inserted before the "input + region" and before the prompt. + (slime-show-last-output): Use it. + (slime-repl-insert-prompt): Initialize it. + (slime-last-output-start): Removed. + (slime-flush-output): Increase delay to 20 usecs. + (slime-with-output-end-mark): Renamed from + slime-with-output-at-eob. Insert a newline if needed. + (slime-output-string, slime-repl-activate): Use it. + (slime-repl-return): Ensure that slime-repl-input-end-mark points + to a reasonable location. + +2003-12-17 Luke Gorrie <luke(a)bluetail.com> + + * HACKING: New file summarising our way of working. + +2003-12-16 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-lisp-preferred-package-nicknames): Removed. Not + very interesting (and slightly broken) now that shortest-nicknames + are automatically used. + (slime-output-oneway-evaluate-request): New function to evaluate + an expression for side-effects (without getting a + result). + (slime-idle-state): Handle new :emacs-evaluate-oneway. + (slime-debugging-state): Handle :emacs-evaluate-oneway. + (sldb-invoke-restart): Use slime-oneway-eval. This avoids pushing + an evaluating state (which will be aborted, and print an unnecessary + message saying so). + (sldb-break-with-default-debugger): New command to break into the + default TTY debugger. Bound to 'B' in *sldb*. + (slime-read-string-state): Added :emacs-evaluate-oneway. + + * swank.lisp (invoke-nth-restart-for-emacs): Wrapper around + INVOKE-NTH-RESTART that checks that Lisp and Emacs agree on the + debug level. This detects and ignores old restart requests when + several are sent at once (possible because of new oneway-eval + feature). + (oneway-eval-string): New function to evaluate a string without + sending a result, and with *DEBUGGER-HOOK* bound to NIL. (The + debugger hook is inhibited to avoid state conflicts.) + +2003-12-15 Luke Gorrie <luke(a)bluetail.com> + + * swank-openmcl.lisp (ccl::*warn-if-redefine-kernel*): Support for + interrupting the listener (by Alan Ruttenberg). + +2003-12-15 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp *start-swank-in-background*: Set to t by default. + + * slime.el (slime-eval-last-expression-display-output): New + command. Bound to C-x M-e. Suggested by Nicolas Neuss. + (slime-display-output-buffer): New function. + (slime-slime-compile-file): Use it. + +2003-12-15 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp (*processing-rpc*, *multiprocessing-enabled*, + *debugger-hook-passback*): New variables. + (with-conversation-lock, with-I/O-lock): New macros. + (read-next-form): Use with-I/O-lock. + (send-to-emacs): Use with-I/O-lock. + (swank-debugger-hook): When called asynchronously (i.e. not + during RPC) and multiprocessing is enabled, suspend until + acknowleged by Emacs. + (install-global-debugger-hook): Install a SLIME-DEBUGGER-FUNCTION + globally on *DEBUGGER-HOOK*. + (startup-multiprocessing-for-emacs): Called to initialize multiprocessing. + (eval-string): Dynamically set the *PROCESSING-RPC* flag. + (eval-string): Nasty hack with *DEBUGGER-HOOK-PASSBACK* to + install debugger hook. Temporary, I swear! + (eval-region, shortest-package-nickname): Report the shortest + package nickname to Emacs (for the REPL prompt). Patch from Marco + Baringer. + + * swank-backend.lisp: Defined multiprocessing interface. + + * swank-cmucl.lisp: Implmemented the multiprocessing interface. + + * slime.el (slime-multiprocessing): When true, use + multiprocessing in Lisp if available. + (slime-global-debugger-hook): When true, globally set + *debugger-hook* to use the SLIME debugger. For use with + SERVE-EVENT and multiprocessing. + (slime-handle-oob): Handle :AWAITING-GOAHEAD message from threads + that have suspended to wait for Emacs's attention. + (slime-give-goahead): New command to allow a suspended thread to + continue (bound to RET in the thread-control-panel). + (slime-thread-control-panel): New command to display a buffer + showing all threads that are suspending waiting for Emacs's + attention. Bound to `C-c C-x t'. + (slime-popup-thread-control-panel): When true, automatically + popup the thread-control buffer when a new thread suspends. + +2003-12-14 Alan Ruttenberg <alanr-l(a)mumble.net> + + * swank-openmcl.lisp (eval-in-frame, inspect-object and friends): + Most of this is copied from swank-cmucl. The parts between &&&&& + are what I added for openmcl. I piggyback off the inspector which + is shipped with openmcl, so inspecting won't look the same as it + would in cmucl, I imagine. Still, it's a start. eval in frame + uses frame-locals to get bindings so if you have debug settings + low or don't have *save-local-symbols* set you won't be able to + evaluate. + +2003-12-14 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-lispworks.lisp (tracedp, toggle-trace-fdefinition): Moved + to swank.lisp. + + * swank-allegro.lisp (create-swank-server): Add support for + BACKGROUND and CLOSE argument. + (call-with-debugging-environment): Use excl::int-newest-frame to + avoid the kludge with *break-hook*. + (sldb-abort): New function. + (frame-source-location-for-emacs): Dummy definition. + (compile-file-for-emacs): The argument is called + :load-after-compile and not :load. + (xref-results-for-emacs): Use dolist instead of loop. + + * swank-openmcl.lisp (create-swank-server): Add support for + BACKGROUND and CLOSE argument. + (open-stream-to-emacs): Support for dedicated output stream. + + * swank.lisp: *start-swank-in-background*, + *close-swank-socket-after-setup*, *use-dedicated-output-stream*: + Moved here from swank-cmucl. + (sldb-continue): Don't pass the condition as argument, because + that doesn't work with Allegro. + (toggle-trace-fdefinition, tracedp): Replace backend specific code + with portable, but ugly, calls to eval. + + * swank-cmucl.lisp (compile-system-for-emacs): Add method for + CMUCL. + + * slime.el (slime-goto-source-location): Better regexp for package + qualified symbols. Allow dashes in the name and two colons. + Reported by Alan Ruttenberg. + +2003-12-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-openmcl.lisp (create-swank-server): Interrupt the right + thread. Patch by Alan Ruttenberg. Not yet enabled, due to lack + of test platform. + (sldb-disassemble): Implement sldb-disassemble command. Patch by + Alan Ruttenberg. + Remove #' from lambdas. + +2003-12-12 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-cmucl.lisp (create-swank-server): New keyword arguments to + control the server: BACKGROUND and CLOSE. fd-handlers are used if + BACKGROUND is true. If close CLOSE is true, close the socket + after the first connection; keep it open otherwise. + *start-swank-in-background*, *close-swank-socket-after-setup*: The + default values of the corresponding arguments for + create-swank-server. + (compile-file-for-emacs): Don't load the fasl-file when the + compilation failed. + + * swank-openmcl.lisp (toggle-trace-fdefinition, tracedp): + Implement trace command. Patch by Alan Ruttenberg. + (find-function-locations, find-source-locations): Handle + variables, and method-combinations. General cleanups. + (source-info-first-file-name): Removed. + (list-callers): Fixed. + (list-callers): Fixed some more. method-name is not exported in + 0.14. From Marco Baringer. + (swank-accept-connection): Accept multiple connections. Patch by + Marco Baringer. + + * swank-loader.lisp (user-init-file): Use homedir's truename. + Reported by Friedrich Dominicus. + + * slime.el (slime-repl-current-input): Don't remove the final + newline if we are in reading state. + (slime-goto-source-location): Regex-quote the function-name and + handle package prefixes. Reported by Alan Ruttenberg. + (slime-output-string): Insert asynchronous output before the + prompt. + +2003-12-12 Daniel Barlow <dan(a)telent.net> + + * swank-source-path-parser.lisp: new file, excerpting part of + swank-cmucl.lisp to where SBCL can find it as well. + +2003-12-11 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-one-line-ify): New function to convert + multi-line strings to one-liners by replacing any newline + followed by indentation by a single space. + (slime-xrefs-for-notes): Use it. + +2003-12-11 Daniel Barlow <dan(a)telent.net> + + * swank-sbcl.lisp (compiler-note-location): replace with + thinly-ported version from the CMUCL backend which understands + :lisp as a pathname + + * slime.el (slime-xrefs-for-notes): a little more temporary + variables, a little less cdr. Should be slightly faster on + big systems + (slime-goto-next-xref): set window point as well as buffer point - + now works in GNU Emacs 21.2.1 + + * swank.lisp (swank-compiler): new function abstracts commonality + between swank-compile-{file, string}. + (swank-load-system): call swank-compiler to load asdf system + + * swank-sbcl.lisp (compiler-note-location and elsewhere): + remove all trace of *compile-filename* + (compile-*-for-emacs): shorten + + * swank-backend.lisp (call-with-compilation-hooks): new GF + should set up all appropriate error condition loggers etc + to do a compilation preserving the notes. Implement for + sbcl, cmucl + + * slime.el (slime-find-asd, slime-load-system): new command + to compile and load an ASDF system with all the usual compiler + notes and stuff + (slime-compilation-finished): if more than one file has new + errors/notes, create an xref buffer to show them all + (slime-remove-old-overlays): bug fix: now removes overlays even + at start of buffer + (slime-overlay-note): do nothing quietly if + slime-choose-overlay-region returns nil + (slime-choose-overlay-region): return nil if note has no location + +2003-12-11 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-repl-previous-prompt, slime-repl-next-prompt): + New commands. Suggested by H�kon Alstadheim. + (slime-repl-beginning-of-defun, slime-repl-end-of-defun): New + commands. Suggested by Andreas Fuchs. + (slime-repl-insert-prompt): Mark the prompt with a + slime-repl-prompt text property. + (slime-repl-eol): New function. Mostly for symmetry. + (slime-repl-in-input-area-p, slime-repl-at-prompt-end-p): New + predicates. + (slime-repl-find-prompt, slime-search-property-change-fn): New + functions. + (slime-ir1-expand): New command. + + * swank-cmucl.lisp (accept-connection, request-loop): Don't use + fd-handlers. The code for the request-loop itself is now almost + the same as in the Allegro version. + (print-ir1-converted-blocks, expand-ir1-top-level): New functions. + +2003-12-10 Daniel Barlow <dan(a)telent.net> + + * swank-sbcl.lisp (serve-request): more fiddling with serve-event + descriptors + + * slime.el (slime-repl-return): slime-check-connected, otherwise + pressing Return in an unconnected repl gets a bit weird + +2003-12-10 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-allegro.lisp, swank-lispworks.lisp, swank-openmcl.lisp, + swank-sbcl.lisp (create-swank-server): Accept an announce-function + keyword argument. + + * swank.lisp (start-server): Pass an announce callback function to + create-swank-server. Works better with single threaded + implementations. + (announce-server-port, simple-announce-function): New functions. + (alistify): Doc fix. + + * swank-cmucl.lisp (create-swank-server): Use announce callback. + (sldb-disassemble): New function. + + * slime.el (sldb-disassemble): New command. Bound to D. + +2003-12-08 Luke Gorrie <luke(a)bluetail.com> + + * swank-cmucl.lisp (*debug-definition-finding*): Now nil by + default, so that errors while looking for definitions are printed + as a message and not debugged. + + * slime.el (slime-read-from-minibuffer): Now the only + completing-read function, stale ones deleted. + +2003-12-07 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (sldb-prune-initial-frames): Use regexp-heuristics and + the '--more--' token to avoid showing the user Swank-internal + backtrace frames initially. + (slime-repl-current-input): Don't include the final newline + character, to make backtraces prettier. + (slime-autodoc): Fixed annoying case where autodocs would be + fetched in a loop for undocumented symbols. + + * swank.lisp (compound-prefix-match): New name and rewritten for + speed. Completion is much faster now. + (*sldb-initial-frames*): Send up to this many (default 20) + backtrace frames to Emacs when entering the debugger. + +2003-12-07 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-allegro.lisp, swank-backend.lisp, swank-cmucl.lisp, + swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp + (function-source-locations): Make it at generic function. + (function-source-location-for-emacs): Removed. Fixes bug reported + by Marco Baringer. + + * slime.el (slime-interactive-eval): Insert the result at point, + if called with prefix argument. + +2003-12-06 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-easy-menu): Added menubar support, contributed + by Friedrich Dominicus. + +2003-12-06 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-allegro.lisp: New file. + + * swank-loader.lisp (user-init-file): Translate logical + pathnames. Reported by Friedrich Dominicus. + + * swank-sbcl.lisp (handle-notification-condition): Don't ignore + warnings without context. + (compiler-note-location, brief-compiler-message-for-emacs, + compiler-note-location): Handle null context. + (compile-file-for-emacs): Bind *compile-filename* and load the + fasl file only if it exists. + (function-source-location): The name argument is now optional and + should be a symbol. + (find-function-locations): Return errors as a list of one error. + (call-with-debugging-environment): Set *print-level* to 4 and + *print-length* to 10. (Both where nil.) + (source-location-for-emacs): Fall back to the location of the + function, if there is no debug-block-info. + (safe-source-location-for-emacs): Don't catch all conditions; only + errors. + *compile-filename*: New variable + (open-listener): Don't make the socket non-blocking. + + * slime.el (slime-eval/compile-defun-dwim): New command. + Suggested by "jan" <janmar(a)iprimus.com.au>. + +2003-12-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-debugging-state): Don't set sldb-level after + sldb-setup. Breaks the test-suite. + (slime-eval-defun): Fix typos. + (slime-xref-buffer, slime-goto-next-xref): Updated for the new + xref code. + (sldb-inspect-in-frame): Query with the sexp at point as initial + value. + (sldb-step): New command. Bound to s. + + * swank-cmucl.lisp (format-frame-for-emacs, compute-backtrace, + backtrace): Don't send CMUCL's frame numbers to Emacs, use our own + numbering. + (set-step-breakpoints, sldb-step): Lisp side of sldb-step command. + +2003-12-04 Luke Gorrie <luke(a)bluetail.com> + + * hyperspec.el: Updated URL to point to a live copy of the + hyperspec at lispworks.com, because the one on xanalys.com has + disappeared. Patch from Vincent Arkesteijn on the ilisp-devel + mailing list. + +2003-12-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-lispworks.lisp (toggle-trace-fdefinition, tracedp): New + support functions for toggle-trace command. Written by Alain + Picard. + (compile-from-temp-file): Don't delete the binary file if there is + none. + (lispworks-severity): Map all ERRORs to :error. + + * slime.el (slime-eval-defun): Use slime-re-evaluate-defvar if the + defun starts with "defvar". C-M-x in elisp does this too. + (slime-re-evaluate-defvar): Take the form as argument. + +2003-12-03 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-debugging-state): Initialize the sldb-buffer if + (/= sldb-level level). + (slime-who-specializes): New command. + + * swank-cmucl.lisp (create-swank-server): Set reuse-address to t + by default. + (resolve-note-location): Add method for warnings in interpreted + code. + (who-specializes): New function. + (dd-source-location): Handle case without constructors more + correctly. + (source-path-source-position): Skip ambigous entries in + source-map. + (source-location-from-code-location): Simplified. + +2003-12-03 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-completing-read-internal): Fix from Sean + O'Rourke. + +2003-12-02 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-sbcl.lisp (find-function-locations): Return a non-empty + list of source locations. + + * slime.el (slime-with-xref-buffer): Remove spurious comma. (Bug + reported by Raymond Wiker). Some reordering of the xref code. + + * swank.lisp (documentation-symbol): New optional argument for + return value if the symbol is not documented. + +2003-12-02 Sean O'Rourke <sorourke(a)cs.ucsd.edu> + + * slime.el: (slime-repl-{clear-buffer,clear-output}): clear the + last and entire output in the *slime-repl* buffer + (slime-documentation): pop up a buffer with a symbol's + documentation instead of its description, if found. + (slime-complete-symbol): tweak the completion, taken from ilisp, to + complete filenames inside strings. + (slime-set-default-directory): also set *slime-repl*'s + default-directory, so e.g. find-file makes sense. + +2003-12-02 Daniel Barlow <dan(a)telent.net> + + * slime.el (slime-with-xref-buffer): moved further up the file so + it's defined before slime-show-xrefs needs it + + * swank-sbcl.lisp (function-source-location-for-emacs): return a + list of source locations (one per method) when the request is + for a GF. This seems to make the elisp side popup a window + to let the user select one. Cool. + +2003-12-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-[cmucl,sbcl,openmcl,lispworks].lisp (invoke-nth-restart): + Use invoke-restart-interactively. + + * slime.el (slime-create-note-overlay, slime-sexp-depth): The + 'priority' property is unused. Remove it. + + * swank-openmcl.lisp (find-function-locations): Return all methods + for generic functions. Doesn't work very well if multiple methods + are in the same file. + (swank-accept-connection): Don't create an extra thread, call + request-loop directly. + +2003-12-01 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-repl-return): Goto end of input area before + inserting newline. + (slime-autodoc-message-ok-p): Test to see if a documentation + message should be printed (returns nil if the + minibuffer/echo-area is already being used). + (slime-symbol-at-point): Skip back over whitespace before + looking for the symbol. + (slime-autodoc-delay): New configurable to specify the delay + before printing an autodoc message (default 0.2 secs). + (slime-ensure-typeout-frame): New function to call create a + typeout frame unless it already exists. Suitable to run on + slime-mode-hook if you always want to have a typeout window. + (slime-log-events): When nil, don't log events to + *slime-events*. This works-around a problem Raymond Toy has when + starting SLIME under XEmacs. Still investigating.. + +2003-11-29 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: Rewrite the xref code to work with other source + locations. + (slime-edit-fdefinition): Use the xref window to display generic + functions with methods. + (slime-goto-source-location): New representation for source + locations. Drop old code. + (slime-list-callers, slime-list-callees): Use the xref window. + Remove the slime-select-* stuff. + (slime-describe-function): New command. Bound to C-c C-f. + Primarily useful in Lispworks. + (slime-complete-symbol): Display the completion window if the + prefix is complete but not unique. + (slime-forward-positioned-source-path): Enter the sexp only if the + remaining sourcepath is not empty. + (slime-read-symbol-name): New optional argument QUERY forces + querying. + + * swank.lisp (group-xrefs): Handle unresolved source locations. + (describe-symbol): Print something sensible about unknown symbols. + + * swank-cmucl.lisp: Use the new format for source locations. + (find-function-locations): New function. Replaces + function-source-location-for-emacs. Returns a list of + source-locations. + (resolve-note-location): Renamed from resolve-location. + Simplified. + (brief-compiler-message-for-emacs): Print the source context + (that's the thing after ==>). + (who-xxxx): Take strings, not symbols, as arguments. + (function-callees, function-callers): Use the same format as the + who-xxx functions. Support for byte-compiled stuff. + (code-location-stream-position): Try to be clever is the source + path doesn't match the form. + (call-with-debugging-environment): Bind *print-readably* to nil. + + * swank-lispworks.lisp: Use the new format for source + locations. Implement the find-function-locations. + (list-callers, list-callers): New functions. + + * swank-sbcl.lisp, swank-openmcl.lisp: Use the new format for + source locations and implement find-function-locations (just calls + the old code). + +2003-11-29 Daniel Barlow <dan(a)telent.net> + + * swank-sbcl.lisp (source-location-for-emacs): + sb-debug::print-description-to-string takes only two args, not + three. Now 'v' command works in sldb :-) + + * slime.el (slime-idle-state): added :debug as a valid transition + + * swank.lisp (slime-debugger-function): New. Returns a function + suitable for use as the value of *DEBUGGER-HOOK* to install the + SLIME debugger globally. Must be run from the *slime-repl* buffer + or somewhere else that the slime streams are visible so that it + can capture them. e.g. for Araneida: + PKG> (setf araneida:*restart-on-handler-errors* + (swank:slime-debugger-fucntion)) + +2003-11-29 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: Some tweaking to the REPL. slime-repl-input-end-mark + is now always left inserting and slime-mark-input-end + "deactivates" the end mark by moving it to the beginning of the + buffer. + (slime-goto-source-location): Next try for more uniform + source-locations. A source-location is now a structure with a + "buffer-designator" and "position-designator". The buffer-designator + open the file or buffer and the position-designator moves point to the + right position. + (slime-autodoc-mode): New command. + (slime-find-fdefinitions): Experimental support for generic functions + with methods. + (slime-show-xrefs, slime-insert-xrefs, slime-goto-xref): Rewritten to + work with more general source locations. + + * swank.lisp: Structure definitions for source-locations. + (alistify, location-position<, group-xrefs): Utilities for xref + support. + + * swank-cmucl.lisp (code-location-source-location): Renamed from + safe-source-location-for-emacs. + (code-location-from-source-location): Renamed from + source-location-for-emacs. + (find-fdefinitions, function-source-locations): New functions. + (safe-definition-finding): New macro. + + * swank-lispworks.lisp: Xref support. + (make-dspec-location): Updated for the new source-location format. + +2003-11-29 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (complete-symbol, arglist): Updated test cases for new + completion interface. + +2003-11-28 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-complete-symbol): Use the new completion + support from the Lisp side. Don't obscure minibuffer input with + completion messages. + + * completer.el: Dead and buried! Replaced by half a page of Common + Lisp. Thanks Bill Clementson for a motivational and well-deserved + taunt. + + * swank.lisp (longest-completion): Compute the best partial + completion for Emacs. + + * slime.el (slime-swank-port-file): Try (temp-directory), + temporary-file-directory, or "/tmp/", depending on what + is (f)bound. + +2003-11-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-lispworks.lisp (make-dspec-location): Handle logical + pathnames. Reported by Alain Picard. + + * swank-sbcl.lisp, swank-cmucl.lisp: Support for output + redirection to an Emacs buffer via a dedicated network stream. + Can be enabled with *use-dedicated-output-stream*. + + * swank.lisp (slime-read-string, eval-string): Flush *emacs-io*. + (eval-in-emacs): New function. + + * slime.el: Support for output from a dedicated socket. + (slime-open-stream-to-lisp, slime-output-filter): New functions. + Reorganized REPL code a bit. + (slime-input-complete-p): Use vanilla forward-sexp, because + slime-forward-sexp sometimes caused endless loops. + (slime-disconnect): Close the output-stream-connection if present. + (slime-handle-oob): A new :%apply event. Executes arbitrary code; + useful for bootstrapping. + (slime-flush-output): New function. + (slime-symbol-end-pos): Didn't work at all in Emacs20. Just use + point until someone commits a proper fix. + Various uses of display-buffer: The second argument is different in + XEmacs. + (interrupt-bubbling-idiot): Reduce the timeout to 5 seconds. + +2003-11-27 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-swank-port-file): Use `temporary-file-directory' + instead of hardcoding "/tmp/". + +2003-11-27 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-lispworks.lisp: New backend. + + * slime.el (slime-with-output-to-temp-buffer): Save the window + configuration in a buffer local variable instead on a global + stack. + (slime-show-last-output): Behavior customizable with + slime-show-last-output-function. Various tweaking for better + multi-frame support. + + * swank-backend.lisp: List exported symbols explicitly. + + * swank-cmucl.lisp (function-source-location): Better support for + generic functions. + + * swank.lisp (briefly-describe-symbol-for-emacs): Don't return + unbound symbols. + (describe-symbol, describe-function): Support package-qualified + strings. + + * swank-loader.lisp: *sysdep-pathnames*: Add Lispworks files. + (compile-files-if-needed-serially): Compile all files in a + compilation unit. + +2003-11-27 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-complete-symbol): Make a bogus alist out of the + completion set, for compatibility with XEmacs. + + * completer.el: Stolen^Wimported from ILISP version 1.4. This is + one revision prior to their latest, where they added a (require) + for some other ILISP code. I backed down a revision to make it + stand-alone, but this may mean that putting SLIME in the load-path + before ILISP will break ILISP. So, beware. + (completer-message): Cut dependency on undefined ilisp constant + testing for xemacs. + +2003-11-27 Zach Beane <xach(a)xach.com> + + * swank.lisp (completions): Complete compound symbols (see below). + + * slime.el (slime-complete-symbol): Use `completer' package to + handle more sophisticated completions. This includes abbreviations + like "m-v-b" => "multiple-value-bind". It also (somewhat scarily) + redefines other standard Emacs completion functions with similar + capabilities. See commentary in completer.erl for details. + +2003-11-25 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-make-typeout-frame): New command to create a + frame where commands can print messages that would otherwise go to + the echo area. + (slime-background-message): Function for printing "background" + messages. Uses the "typeout-frame" if it exists. + (slime-arglist): Print arglist with `slime-background-message'. + (slime-message): Use typeout frame if it exists, but only for + multi-line messages. + +2003-11-25 Daniel Barlow <dan(a)telent.net> + + * swank-sbcl.lisp: delete big chunk of leftover commented-out + code + + * slime.el: arglist command to use slime-read-symbol-name, + not slime-read-symbol + + * README: Minor updates for currency + +2003-11-24 Luke Gorrie <luke(a)bluetail.com> + + * swank-backend.lisp (compiler-condition): Removed use of + :documentation slot option. That is not portable (to CMUCL 18e). + + * swank.lisp (eval-string-in-frame): Fixed symbol-visibility + problem (thanks Lawrence Mitchell). + + * swank-sbcl.lisp (function-source-location): Use TRUENAME to + resolve source file name (thanks Lawrence Mitchell). + + * slime.el (slime-goto-source-location): Fixes when finding + definition by regexp: open the right file (was missed), and + tweaked regexp to match more 'def' forms - especially + `defmacro-mundanely' (hyphen wasn't allowed before). + +2003-11-23 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (sldb-fetch-more-frames): Call swank:backtrace instead + of (renamed) swank:backtrace-for-emacs. + + * swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl-lisp: Updated + to use new debugger interfaces in swank-backend.lisp. + + * swank-backend.lisp (backtrace, eval-in-frame, frame-catch-tags, + frame-locals, frame-source-location-for-emacs): More interface + functions. + + * slime.el (slime-goto-source-location): Added optional `align-p' + argument for :file and :emacs-buffer location types. This is for + OpenMCL - unlike CMUCL its positions are not character-accurate so + it needs to be aligned to the beginning of the sexp. + (slime-connect): Don't delete a random window when *inferior-lisp* + isn't visible. + + * swank-cmucl.lisp: Tidied up outline-minor-mode structure and + added comments and docstrings. + + * swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl-lisp: Updated + to use new debugger interface in swank-backend.lisp. + + * swank-backend.lisp (call-with-debugging-environment, + sldb-condition, debugger-info-for-emacs): More callbacks defined. + + * swank.lisp: Tidied up outline-minor-mode structure, added + comments and docstrings. + (sldb-loop): Took over the main debugger loop. + + * swank-openmcl.lisp: Updated after refactoring of other backends + (was broken). + + * slime.el (slime-goto-source-location): Align at beginning of + sexp after (:file name pos) and (:emacs-buffer buffer pos). + + * swank-sbcl.lisp (describe-symbol-for-emacs): Don't ask for + (documentation SYM 'class), CLHS says there isn't any 'class + documentation (and SBCL warns). + + * swank.lisp, swank-cmucl.lisp, swank-sbcl.lisp: Refactored + interface through swank-backend.lisp for: swank-compile-file, + swank-compile-string, describe-symbol-for-emacs (apropos), + macroexpand-all, arglist-string. + + * swank-backend.lisp: New file defining the interface between + swank.lisp and the swank-*.lisp implementation files. + +2003-11-22 Brian Mastenbrook <bmastenb(a)cs.indiana.edu> + + * swank.asd: ASDF definition to load "swank-loader.lisp". This is + useful for starting the Swank server in a separate Lisp and later + connecting with Emacs. The file includes commentary. + +2003-11-22 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-connect): Slightly reordered some window + operations to ensure that *slime-repl* is popped up after `M-x + slime-connect'. + (slime-show-last-output): If the *slime-repl* buffer is already + visible in any frame, don't change anything. + + * swank.lisp (listener-eval): Format results in *buffer-package*. + Exporting (CREATE-SWANK-SERVER <port>). This function can be + called directly to start a swank server, which you can then + connect to with `M-x slime-connect'. It takes a port number as + argument, but this can be zero to use a random available port. + The function always returns the actual port number being used. + +2003-11-19 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp: Better printing off return values. In the REPL + buffer we print now every value in a separate line and in the echo + area separated by a comma. We also print "; No value" for the + degenerated case (values). A new variable *sldb-pprint-frames* + controls the printing of frames in the debugger. (Thanks Raymond + Toy for the suggestions.) + + * swank-cmucl.lisp (format-frame-for-emacs): Bind *pretty-print* + to *sldb-pprint-frames*. + + * slime.el: Window configuration are now saved on a stack, not in + a single global variable. + (slime-with-output-to-temp-buffer) We use now our own version of + with-output-to-temp-buffer. The default version is painfully + incompatible between Emacs versions. The version selects the + temporary buffer and the behaivor of "q" is now more consistent + (as suggested by Jan Rychter). + (slime-connect): Hide the *inferior-lisp-buffer* when we are + connected. + sldb-mode-map: Bind n and p to sldb-down and sldb-up. + (slime-edit-fdefinition-other-window): New function. Suggested by + Christian Lynbech. + + * swank-loader.lisp (user-init-file): There is now a user init + file (~/.swank.lisp). It is loaded after the other files. + +2003-11-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: [slime-keys] Override C-c C-r with slime-eval-region + (reported by Paolo Amoroso). + + * swank-loader.lisp: Compile and load gray stream stuff for SBCL + and OpenMCL. + + * swank-openmcl.lisp, swank-sbcl.lisp: Import gray stream symbols. + (without-interrupts*): New function. + + * swank.lisp (send-to-emacs): Protect the write operations by a + without-interrupts, so that we don't trash the *cl-connection* + buffer with partially written messages. + + * swank-cmucl.lisp (without-interrupts*): New function. + + * swank-gray.lisp (stream-write-char): Don't flush the buffer on + newlines. + + * slime.el: Add some docstring. + (interrupt-bubbling-idiot): New test. + [slime-keys]: Don't bind "\C- ". Problematic on LinuxPPC. + +2003-11-15 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: Some tweaking for better scrolling in the *slime-repl* + buffer (suggested by Jan Rychter). + (slime-compile-file): Display the output buffer at the beginning. + (slime-show-last-output): Include the prompt so that window-point + is updated properly. + (slime-with-output-at-eob): Update window-point if the buffer is + visible. + (slime-state/event-panic): Include the *slime-events* and + *cl-connection* buffers in the report. + + * swank-cmucl.lisp (sos/out): Don't flush the buffer on newlines. + +2003-11-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: Imititate an "output-mark". Output from Lisp should + move point only if point is at the end of the buffer. (Thanks + William Halliburton for the suggestion.) + (slime-with-output-at-eob): New function. + (slime-output-string, slime-repl-maybe-prompt): Use it. + + slime-repl-mode-map: Override "\C-\M-x". + + An experimental scratch buffer: + (slime-eval-print-last-expression): New function. + (slime-scratch-mode-map, slime-scratch-buffer, + slime-switch-to-scratch-buffer, slime-scratch): New functions. + + * swank-cmucl.lisp (resolve-location): Emacs buffer positions are + 1 based. Add 1 to the 0 based file-position. + +2003-11-13 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-connect): pop-to-buffer into *slime-repl* when + we connect. + +2003-11-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el, swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl: New + representation for "source-locations". Compiler notes have now a + message, a severity, and a source-location field. Compiler notes, + edit-definition, and the debugger all use now the same + representation for source-location. CMUCL does the source-path to + file-position translation at the Lisp side. This works better + with reader macros, in particular with backquote. The SBCL + backend still does the translation on the Emacs side. OpenMCL + support is probably totally broken at the moment + +2003-11-13 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-repl-previous-input, slime-repl-next-input): + When partial input has already been entered, the M-{p,n} REPL + history commands only match lines that start with the + already-entered prefix. This is comint-compatible behaviour which + has been requested. The history commands also skip over line + identical to the one already entered. + (slime-complete-maybe-restore-window-confguration): Catch errors, + so that we don't cause `pre-command-hook' to be killed. + (slime-truncate-lines): If you set this to nil, slime won't set + `truncate-lines' in buffers like sldb, apropos, etc. + +2003-11-12 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-show-description): XEmacs portability: don't use + `temp-buffer-show-hook'. + (slime-inspect): Use `(slime-sexp-at-point)' as default inspection + value (thanks Jan Rychter). + +2003-11-10 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-post-command-hook): Inhibit unless (still) in + slime-mode. Only call `slime-autodoc-post-command-hook' when + `slime-autodoc-mode' is non-nil. + (slime-setup-command-hooks): Use `make-local-hook' instead of + `make-local-variable'. + +2003-11-08 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: slime-highlight-face: Use the :inherit attribute if + possible. + (slime-face-inheritance-possible-p): New function. + + * slime.el (slime-repl-return): Only send the current input to + Lisp if it is a complete expression, like inferior-slime-return. + + * swank.lisp (completions): Use *buffer-package* if no other + package is given. + + * slime.el: Remove the non-working face inheriting stuff. + Hardcode colors for slime-highlight-face and specify the :inherit + attribute for slime-repl-output-face. So Emacs21 will do the + right thing and the others get at least a customizable face. + + * slime.el (slime-buffer-package): Try to find be the + package name before resorting to slime-buffer-package. Return nil + and not "CL-USER" if the package cannot be determined. + (slime-goto-location): Insert notes with a source path, but + without filename or buffername, at point. This can happen for + warnings during macro expansion. (The macro expander is a + interpreted function and doesn't have a filename or buffername.) + (slime-show-note): Display 2 double quotes "" in the echo area for + zero length messages. SERIES tends to signal warnings with zero + length messages. + (slime-print-apropos): Add support for alien types. + + * swank-cmucl.lisp (briefly-describe-symbol-for-emacs): Add + support for alien types. + (source-path-file-position): Read the entire expression with a + special readtable. The readtable records source positions for + each sub-expression in a hashtable. Extract the sub-expression + for the source path from the read object and lookup the + sub-expression in the hashtable to find its source position. + + * swank-sbcl.lisp (swank-macroexpand-all): Implemented. + +2003-11-06 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-autodoc-mode): When non-nil, display the + argument list for the function-call near point each time the point + moves in a slime-mode buffer. This is a first-cut; more useful + context-sensitive help to follow (e.g. looking up variable + documentation). + (slime-autodoc-cache-type): Cache policy "autodoc" documentation: + either nil (no caching), 'last (the default - cache most recent + only), or 'all (cache everything on symbol plists forever). + + * slime.el: Convenience macros: + (when-bind (var exp) &rest body) + => (let ((var exp)) (when var . body)) + (with-lexical-bindings (var1 ...) . body) + => (lexical-let ((var1 var1) ...) . body) + + * slime.el (slime, slime-lisp-package): Reset `slime-lisp-package' + (the REPL package) when reconnecting. + (slime-buffer-package): Return `slime-lisp-package' when the + major-mode is `slime-repl-mode'. + +2003-11-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-read-string-state): Add support for evaluation + requests. + (slime-repl-read-break): New command. + alternative. + slime-keys: XEmacs cannot rebind C-c C-g. Use C-c C-b as an + alternative. + (slime-selector): XEmacs has no prompt argument for read-char. + (slime-underline-color, slime-face-attributes): Make face + definitions compatible with XEmacs and Emacs20. + (slime-disconnect): Delete the buffer of the socket. + (slime-net-connect): Prefix the connection buffer name with a + space to avoid accidental deletion. + + * swank.lisp (slime-read-string): Send a :read-aborted event for + non-local exits. + (case-convert): Handle :invert case better. + +2003-11-03 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-display-message-or-view, + slime-remove-message-window): Display too long lines in a new + window. Add a temporary pre-command-hook to remove the multiline + window before the next command is executed. + + (slime-complete-symbol): Save the window configuration before + displaying the completions and try to restore it later. The + configuration is restored when: (a) the completion is unique (b) there + are no completion. It is also possible to delay the restoration until + (c) certain characters, e.g, space or a closing paren, are inserted. + + (slime-selector): Don't abort when an unkown character is pressed; + display a message and continue. Similiar for ?\?. Add a selector for + the *sldb* buffer. + + (slbd-hook, sldb-xemacs-post-command-hook): Emulate Emacs' + point-entered text property with a post-command hook. + + * swank.lisp (case-convert, find-symbol-designator): New + functions. + + * swank-cmucl.lisp, swank-openmcl.lisp, swank-sbcl.lisp + (arglist-string): Don't intern the function name. Use + find-symbol-designator instead. + +2003-11-03 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-display-buffer-region): Hacked to fix completely + inexplicable XEmacs problems. + +2003-11-2 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * null-swank-impl.lisp, swank-cmucl.lisp, swank-openmcl.lisp, + swank.lisp: Input redirection works now on the line level, like a + tty. Output streams are now line buffered. We no longer compute + the backtrace-length. + + * slime.el: + (slime-repl-read-mode, slime-repl-read-string, slime-repl-return, + slime-repl-send-string, slime-read-string-state, + slime-activate-state): Reorganize input redirection. We no longer + work on the character level but on a line or region; more like a + terminal. This works better, because REPLs and debuggers are + usually written with a line buffering tty in mind. + (sldb-backtrace-length, slime-debugging-state, + slime-evaluating-state, sldb-setup, sldb-mode, sldb-insert-frames, + sldb-fetch-more-frames): Don't use backtrace-length. Computing + the length of the backtrace is (somewhat strangely) an expensive + operation in CMUCL, e.g., it takes >30 seconds to compute the + length when the yellow zone stack guard is hit. + +2003-11-02 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-log-event): Added a *slime-events* buffer + recording all state machine events. The buffer uses hideshow-mode + to fold messages down to single lines. + (slime-show-source-location): Bugfix: only create source-highlight + overlay if the source was actually located. + (slime-selector): Renamed from `slime-select' because that + function name was already in use. Ooops! + + * swank.lisp (eval-string): force-output on *slime-output* before + returning the result. This somewhat works around some trouble + where output printed by lisp is being buffered too long. + + * slime.el (slime-lisp-package-translations): Association list of + preferred package nicknames, for the REPL prompt. By default maps + COMMON-LISP->CL and COMMON-LISP-USER->CL-USER. + +2003-11-01 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-select): Added an extensible "Select" command, + which I gather is a LispM/Martin-Cracauer knock-off. When invoked, + the select command reads a single character and uses that to + decide which buffer to switch to. New characters can be defined, + and the currently availables ones can be seen with '?'. I have not + assigned a key to Select, because it seems like a command that + should have a global binding. I would suggest `C-c s'. + + * swank.lisp (*slime-features*): Variable remembering the FEATURES + list. + (sync-state-to-emacs): Update Emacs about any state changes - + currently this just means changes to the FEATURES list. + (eval-string): Call `sync-state-to-emacs' before sending result. + (eval-region): With optional PACKAGE-UPDATE-P, if the evaluation + changes the current package, tell Emacs about the new package. + (listener-eval): Tell `eval-region' to notify Emacs of package + changes, so that e.g. (in-package :swank) does the right thing + when evaluated in the REPL. + + * slime.el (slime-repl-output-face, slime-repl-input-face): Face + definitions for output printed by Lisp and for previous REPL user + inputs, respectively. Defaulting the input face to bold rather + than underline, because it looks better on multi-line input. + (slime-handle-oob): Two new out-of-band messages + (:new-features FEATURES) and (:new-package PACKAGE-NAME). These + are used for Lisp to tell Emacs about changes to *FEATURES* and + *PACKAGE* when appropriate. + (slime-same-line-p): Better implementation (does what the name + suggests). + (slime-lisp-package): New variable keeping track of *PACKAGE* in + Lisp -- or at least, the package to use for the REPL. + (slime-repl-insert-prompt): The prompt now includes the package + name. + (slime-repl-bol): C-a in the REPL now stops at the prompt. + (slime-repl-closing-return): C-RET & C-M-m now close all open + lists and then send input in REPL. + (slime-repl-newline-and-indent): C-j in REPL is now better with + indentation (won't get confused by unmatched quotes etc appearing + before the prompt). + +2003-11-1 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-debugging-state): Save the window configuration + in a state variable. + sldb-saved-window-configuration: Removed. + (slime-repl-mode): Use conservative scrolling. + (slime-repl-insert-prompt): Set window-point after the prompt. + (slime-repl-add-to-input-history): Don't add subsequent duplicates to + the history. + + * swank.lisp (slime-read-char): Flush the output before reading. + (listener-eval): Like eval region but set reader variables (*, **, + *** etc.) + + * swank-openmcl.lisp, swank-sbcl.lisp: Implement stream-line-column. + + * swank-cmucl.lisp (slime-input-stream-misc-ops): Renamed from + slime-input-stream-misc. + +2003-10-31 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-repl-mode-map): Bound `slime-interrupt' on both + C-c C-c and C-c C-g. + + * swank.lisp (interactive-eval): Evaluate in *buffer-package*. + + * slime.el: Tweaked debugger window management somewhat: the + window configuration is saved when the debugger is first entered + and then restored when the idle state is reached. + +2003-10-31 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: (slime-repl-read-mode, slime-repl-read-xxx): New minor + mode for stream character based input to Lisp. + + * swank.lisp: *read-input-catch-tag*, take-input, slime-read-char: + Moved here from swank-cmucl.lisp. + (defslimefun, defslimefun-unimplemented): Move macro definitions to + the beginning of the file. + + * swank-cmucl.lisp: (slime-input-stream, slime-input-stream-read-char, + lime-input-stream-misc): Character input stream from Emacs. + (slime-input-stream/n-bin): Removed. + + * swank-openmcl.lisp, swank-sbcl.lisp: Gray stream based input + redirection from Emacs. + +2003-10-29 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: + Beginnings of a REPL-mode. + Minor debugger cleanups. + + * swank.lisp: + slime-read-error: New condition. + (read-next-form): Re-signal the conditions as slime-read-errors. And + check the result of read-sequence (i.e. detect CMUCL's read-sequence + bug). + (sldb-continue, throw-to-toplevel): Was more or less the same in all + backends. + + * swank-openmcl.lisp, swank-sbcl.lisp, swank-cmucl.lisp: + (serve-request): Handle slime-read-errors and bind a + slime-toplevel catcher. + + * swank-cmucl.lisp: + (sldb-loop): Flush output at the beginning. + (inspect-in-frame): New function. + (frame-locals): Don't send the validity indicator across wire. Too + cmucl specific. + +2003-10-29 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-net-sentinel): Only show a message about + disconnection if the inferior-lisp is still running. + (slime-interrupt, slime-quit): Only send the quit/interrupt + message to Lisp if it is in fact evaluating something for us. This + fixes a protocol bug reported by Paolo Amoroso. Added (require + 'pp). + +2003-10-28 James Bielman <jamesjb(a)jamesjb.com> + + * null-swank-impl.lisp: New file. + + * swank-openmcl.lisp: Pre-refactoring updates to the OpenMCL backend: + (map-backtrace): Renamed from DO-BACKTRACE. + (frame-source-location-for-emacs): New function. + (function-source-location-for-emacs): New function, + + * swank-openmcl.lisp: Docstring updates/additions. + +2003-10-25 Luke Gorrie <luke(a)bluetail.com> + + * Everywhere: Changed the connection setup to use a dynamic + collision-free TCP port. The new protocol is this: + + Emacs calls (swank:start-server FILENAME) via the + listener. FILENAME is /tmp/slime.${emacspid} + Lisp starts a TCP server on a dynamic available port and writes + the port number it gets to FILENAME. + Emacs asynchronously polls for FILENAME's creation. When it + exists, Emacs reads the port number, deletes the file, and makes + the connection. + + The advantage is that you can run multiple Emacsen each with an + inferior lisp, and the port numbers will never collide and Emacs + will always connect to the right lisp. + + All backends are updated, but only CMUCL and SBCL are + tested. Therefore, OpenMCL is almost certainly broken just now. + + * slime.el (inferior-slime-closing-return): New command that + closes all open lists and sends the result to Lisp. Bound to C-RET + and (for people who use C-m for RET) C-M-m. + (inferior-slime-indent-line): Improved indentation in the inferior + list buffer. + +2003-10-24 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (inferior-slime-return): Command bound to RET in + inferior-slime-mode: only send the current input to Lisp if it is + a complete expression (or prefix argument is given). Two reasons: + it makes the input history contain complete expressions, and it + lets us nicely indent multiple-line inputs. (Thanks Raymond Toy + for the suggestions.) + +2003-10-23 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-maybe-start-lisp): Restart inferior-lisp if the + process has died. + + * swank-sbcl.lisp (accept-connection): Use a character stream to + match swank.lisp. + +2003-10-22 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-cmucl.lisp (setup-request-handler): Create a character + stream. + (read-next-form): Removed. + + * swank.lisp (read-next-form, send-to-emacs): Assume *emacs-io* is + a character stream. Add the necessary char-code/code-char + conversions. + + * slime.el: slime-keys: Add :sldb keywords for keys useful in the + debugger. + (slime-init-keymaps): Allow allow :sldb keywords. + + inferior-lisp-mode-hook: Display the inf-lisp buffer if there is + some output. + + (slime-process-available-input): Start a timer to process any + remaining input. + (slime-dispatch-event): The timer should take care of any lost + input. So don't process the available input here. Remove the + process-input argument. + (slime-push-state, slime-pop-state, slime-activate-state, + slime-idle-state, slime-evaluating-state): Update callers. + (slime-debugging-state): Remove the unwind-protect in the + :debug-return clause. Should not be necessary. + + sldb-mode-map: Define more slime-mode keys. + + (slime-time<, slime-time-add): Removed. Emacs-21 has equivalent time + functions. + (slime-sync-state-stack): Use Emacs-21 time-date functions. + (seconds-to-time, time-less-p, time-add): Compatibility defuns. + +2003-10-22 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime): With a prefix argument, prompt for the port + number to use for communication with Lisp. This is remembered for + future connections. + +2003-10-22 Hannu Koivisto <azure(a)iki.fi> + + * slime.el (slime-space): Now allows one to insert several spaces + with a prefix argument. + +2003-10-21 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-space): Don't give an error when not connected, + to avoid feeping. + + * swank-sbcl.lisp (swank-compile-string): Include only one + :SOURCE-PATH attribute in the plist, and replace the front element + with a 0 (fixes a problem probably due to recent hacks to the + elisp source-path lookups). + + * slime.el (inferior-slime-mode): New minor mode for use with + `inferior-lisp-mode'. Defines a subset of the `slime-mode' keys + which don't clash with comint (e.g. doesn't bind M-{p,n}). + (slime-keys): List of keybinding specifications. + (slime-find-buffer-package): If we don't find the "(in-package" by + searching backwards, then try forwards too. + + * swank.lisp (completions): Fixed semantics: should now consider + only/all completions that would not cause a read-error due to + symbol visibility. Also avoiding duplicates and sorting on + symbol-name. + +2003-10-20 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp (completions): Slight change of semantics: when a + prefix-designator is package-qualified, like "swank:", only match + symbols whose home-package matches the one given - ignore + inherited symbols. + + * slime.el: Updated test suite to work with the different backends: + (find-definition): Lookup definitions in swank.lisp. + (arglist): Lookup arglists of functions in swank.lisp. + +2003-10-20 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (interactive-eval): Make test case independent of + *print-case*. + +2003-10-20 Luke Gorrie <luke(a)bluetail.com> + + * swank-cmucl.lisp (clear-xref-info): Conditionalised + xref:*who-is-called* and xref:*who-macroexpands* with + #+CMU19. This makes SLIME compatible with CMUCL 18e, but also + disables the `who-macroexpands' command in any CMUCL version that + doesn't have the "19A" feature (which does break the command in + some snapshot builds that can actually support it). + +2003-10-20 Daniel Barlow <dan(a)telent.net> + + * swank.lisp (*notes-database*): tyop fix + + * swank-sbcl.lisp (throw-to-toplevel): select TOPLEVEL restart + instead of throwing to a catch that no longer exists + + * slime.el: change some strings containing 'CMUCL' to more + backend-agnostic phrases + +2003-10-19 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el, swank-cmucl.lisp, swank.lisp: First shoot at input + redirection. + + * swank-sbcl.lisp, swank-openmcl.lisp: Bind *slime-input* and + *slime-io* to dummy values. + +2003-10-19 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime): Connection setup is now asynchronous, with + retrying on a timer. This makes it possible to bring the server up + by hand while debugging. `M-x slime' while already connected will + cause the old connection to be dropped and a new one established. + (slime-disconnect): New command to disconnect from Swank, or + cancel asynchronous connection attempts when not yet connected. + (slime-state/event-panic): Illegal events in the communication + state machine now trigger a general panic that disconnects from + Lisp, and displays a message describing what has happened. This is + a bug situation. + (slime-connect): Print a message during connection attempts unless + the minibuffer is active (it's annoying to get messages while + trying to enter commands). + +2003-10-18 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: Fix some bugs in the state machine and be a bit more + careful when processing pending input. + (slime-compile-region): New command. + Some more tests. + +2003-10-17 James Bielman <jamesjb(a)jamesjb.com> + + * .cvsignore: Add OpenMCL and SBCL fasl file extensions. + + * swank-openmcl.lisp (who-calls): Fix bug where we would try to + take the TRUENAME of NIL when source information isn't available + for a caller. + (backtrace-for-emacs): Clean up the backtrace code a bit in + preparation for implementing FRAME-LOCALS. + (frame-catch-tags): Implement a stub version of this. + (frame-locals): Implemented fully for OpenMCL. + + * swank-loader.lisp (compile-files-if-needed-serially): Be a little + more verbose when compiling files. + +2003-10-17 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp, swank-sbcl.lisp, swank-openmcl.lisp, + swank-cmucl.lisp: Move more stuff to swank.lisp. + +2003-10-17 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-post-command-hook): Check that we are connected + before trying to process input. + (slime-net-connect): Handle `network-error' condition for XEmacs + 21.5. (Thanks Raymond Toy.) + + * swank-sbcl.lisp: Report style-warnings separately from notes + (patch from Christophe Rhodes). Use REQUIRE to load sb-introspect + instead of loading the source file (requires the sb-introspect + library to be installed, which doesn't yet happen in the + sourceforge-lagged SBCL anoncvs, but does in the real one). + + * slime.el (slime-style-warning-face): Added style-warnings, which + are between a warning and a note in severity. (Patch from + Christophe Rhodes). + + * test.sh: When the test fails to complete, print "crashed" + instead of reporting nonsense. + +2003-10-17 James Bielman <jamesjb(a)jamesjb.com> + + * swank.lisp (apropos-symbols): Change back to using the standard + 2-argument APROPOS-LIST and check symbols explicitly when + EXTERNAL-ONLY is true. + Move loading of sys-dependent backend code into 'swank-loader'. + + * swank-sbcl.lisp: Moved declarations of *PREVIOUS-COMPILER-CONDITION* + into 'swank.lisp' to kill warnings about undefined variables. + + * swank-openmcl.lisp (handle-compiler-warning): Use source position + instead of function name for warning locations. + (swank-compile-string): Compile into a temporary file instead of + using COMPILE so finding warning positions works when using C-c C-c. + (compute-backtrace): Don't display frames without a function. + (apropos-list-for-emacs): Implement APROPOS. + (who-calls): Implement WHO-CALLS. + (completions): Implement COMPLETIONS. + Use NIL instead of zero so FRESH-LINE does the right thing. + + * slime.el (slime-maybe-compile-swank): Removed function---compile + the backend using 'swank-loader.lisp' instead. + (slime-backend): Changed default backend to 'slime-loader'. + (slime-lisp-binary-extension): Deleted as this is no longer needed. + + * swank-loader.lisp: New file. + +2003-10-17 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-net-connect): Check that + `set-process-coding-system' is fbound before calling it. This is + needed in the XEmacs I built from sources. + +2003-10-17 Daniel Barlow <dan(a)telent.net> + + * swank-sbcl.lisp: Transplanted Helmut's serve-event server to + replace the existing thread-using server. SLIME now has no + dependency on SB-THREAD + + * slime.el (slime-find-buffer-package): handle errors from (read) + for the case where the buffer ends before the in-package form does + (slime-set-package): insert missing comma + (slime-goto-source-location): sbcl has a disagreement with emacs + over the meaning of a character position. Level up with + C-M-f C-M-b + + * assorted typo fixes + +2003-10-16 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-forward-source-path): Improved somewhat. Seems + to work for all common cases except backquote. Backquote is + tricky, because the source-paths are based on the reader's + expansion, e.g.: + * (let ((*print-pretty* nil)) + (print (read-from-string "`(a ,@(b c) d)"))) + --> + (COMMON-LISP::BACKQ-CONS (QUOTE A) + (COMMON-LISP::BACKQ-APPEND (B C) + (QUOTE (D)))) + Must investigate whether we need to write a hairy + backquote-traversing state machine or whether this is something + that could be fixed in CMUCL. + + * swank*.lisp (with-trapping-compiler-notes): This macro is now + defined here, and expands to a call to the backend-defined + `call-trapping-compiler-notes' with the body wrapped in a + lambda. This is to avoid swank.lisp referring to macros in the + backends -- it gets compiled first so it thinks they're functions. + + * slime.el (slime-swank-connection-retries): New default value is + `nil', which means unlimited retries (until user aborts). Retry + interval also reduced from once per second to four times per + second. + +2003-10-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank-cmucl.lisp, swank.lisp: Fix CMUCL support. + +2003-10-15 Daniel Barlow <dan(a)telent.net> + + * swank.lisp: rearrange the backends. rename swank.lisp to + swank-cmucl.lisp, then create new swank.lisp which loads an + appropriate backend according to *features*. Next up, + identify common functions in the backends and move them + into swank.lisp + +2003-10-15 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: Inspector support. list-callers, list-callees + implemented without xref. + + * swank.lisp: Lisp side for inspector and list-callers, + list-calees. Better fdefinition finding for struct-accessors. + + +2003-10-15 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-point-moves-p): Macro for executing subforms and + returning true if they move the point. + + * test.sh: New file to run the test suite in batch-mode. Will need + a little extending to allow configuring the right variables to + work with non-CMUCL backends. + + * slime.el: Set `indent-tabs-mode' to nil. This makes diffs look + better. + (slime-start-swank-server): Now passing the port number to + SWANK:START-SERVER. + (slime-evaluating-state): Debugging synchronous evaluations with + recursive edits now works. + (slime-forward-sexp): Added support for #|...|# reader comments. + (sldb-hook): New hook for entry to the debugger (used for the test + suite). + (slime-run-tests): Reworked the testing framework. Now presents + results in an outline-mode buffer, with only the subtrees + containing failed tests expanded initially. + (slime-check): Check-name can now be a string or + format-control. (Test cases have been updated to take advantage of + this.) + (compile-defun): This test case now works for the case containing + #|..|# + (async-eval-debugging): New test case for recursively debugging + asynchronous evaluation. + +2003-10-15 Daniel Barlow <dan(a)telent.net> + + * README.sbcl: new file + + * README: update for new backends, change of hosting provider + + * swank-sbcl.lisp: new file. + New SWANK backend for Steel Bank Common Lisp, adapted from + swank.lisp with bits of swank-openmcl.lisp + +2003-10-12 Daniel Barlow <dan(a)telent.net> + + * slime.el (sldb-mode-map): add mouse-2 clickability for areas + in sldb buffers covered by the sldb-default-action property: + restarts can now be mouse-activated + +2003-09-28 James Bielman <jamesjb(a)jamesjb.com> + + * swank-openmcl.lisp: New file, a Slime backend for OpenMCL 0.14.x. + (condition-function-name): Figure out the name of methods correctly + instead of passing a list to Emacs. + + * slime.el (slime-goto-location): Try to position notes based on + some (questionable) regex searching if the :FUNCTION-NAME property + is set. Used in the OpenMCL backend which does not support source + paths. + +2003-09-29 Luke Gorrie <luke(a)bluetail.com> + + * slime.el: Fairly major hacking. + Rewrote the evaluation mechanics: similar design but some macros + to make it look more like a push-down automaton (which it really + was!). Debugging Lisp no longer uses recursive edits, partly as a + side-effect and partly to see if it's better this way. + Removed the asynchronous-communication test cases that tested + something we decided not to do. + (slime-eval-string-async): Give a meaningful error message when + trying to make a request while already busy. + (slime-lisp-binary-extension): Uh oh, time to start taking out + gratuitous CMUCL-isms. This variable renamed from + `slime-cmucl-binary-extension'. + (slime-backend): Name of the Lisp backend file, defaulting to + "swank", but can be set to e.g. "swank-openmcl". + + * swank.lisp: Minor protocol changes to accomodate slime.el's + changes above. + +2003-09-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp + (getpid, set-package, set-default-directory): New functions. + (slime-out-misc): Don't send empty strings. + (*redirect-output*, read-from-emacs): A new switch to turn output + redirection off. Useful for debugging. + (interactive-eval, interactive-eval-region, pprint-eval, + re-evaluate-defvar): Bind *package* to *buffer-package*. + (with-trapping-compilation-notes): Add a dummy argument for better + indentation. + (measure-time-intervall, call-with-compilation-hooks): Measure + compilation time. + (frame-locals): Use di::debug-function-debug-variables instead of + di:ambiguous-debug-variables. Don't access non-valid variables. + + * slime.el + (slime-display-message-or-view): Delete old multi-line windows. + (slime-read-package-name): Added an optional initial-value + argument. slime-pid: New variable. + (slime-init-dispatcher): Initialize slime-pid. + (slime-send-sigint): Use slime-pid instead of inferior-lisp-proc. + (slime-eval): Accept debug-condition messages. + (slime-output-buffer): Turn slime-mode on. + (slime-switch-to-output-buffer): New command. Bound to C-c C-z. + (slime-show-note-counts): Display compilation time. + (slime-untrace-all, slime-set-package, slime-set-default-directory + slime-sync-package-and-default-directory): New commands. + (slime-princ-locals): Don't access non-valid variables. This may + cause segfaults and severely confuse CMUCL. + (slime-define-keys): New macro. + +2003-09-28 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp (create-swank-server): Bind the listen-socket on the + loopback interface by default, so that remote machines can't + connect to the Swank server. + +2003-09-27 Luke Gorrie <luke(a)bluetail.com> + + * swank.lisp (with-trapping-compilation-notes): New macro for + bindings the handlers to record compiler notes. Now being used in + `compile-string', which I had broken when removing the compilation + hook. + + * slime.el (slime-function-called-at-point): Rewritten to work + better. Now considers "((foo ..." _not_ to be a function call to + foo because of the double ('s - this will keep it from misfiring + in e.g. LET bindings. + (def-slime-test): All tests now being with (slime-sync). This + fixes some accidental/bogus test failures. + + * swank.lisp (handle-notification-condition): Rewrote + compiler-note collection. Now it uses lower-level condition + handlers instead of c:*compiler-notification-function*. This way + the error messages are tailored to omit redundant information, + like the filename and original source text (which are displayed + and highlighted in Emacs already). Much nicer. + (sort-contexts-by-source-path): Now sorting xref results by + lexical source-path order, so that you're always jumping in the + same direction. + (*debug-definition-finding*): New variable. You can set this to + true if you want to be popped into the debugger when M-. fails to + find a definition (for debugging the + definition-finding). Otherwise it reports the error to Emacs as a + message, like "Error: SETQ is a special form." + + * slime.el (slime-fetch-features-list): New command to fetch the + *FEATURES* list from Lisp and store it away. This is done + automatically upon connection, but can also be called manually to + update. + (slime-forward-reader-conditional): Now does the right things with + reader-conditionals (#+ and #-) based on the Lisp features. + +2003-09-26 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (sldb-setup): Setting `truncate-lines' to t in the + debug buffer. I like having the backtrace take strictly one line + per frame, since otherwise a few ugly arguments (e.g. streams) can + chew up a lot of space. (Can make this a configurable on request + if tastes differ :-) + + * swank.lisp: Did a little defensive programming so that asking + for the definition of an unbound function will return nil to Emacs + instead of entering the debugger. + (format-frame-for-emacs): Binding *PRETTY-PRINT* to nil when + formatting frames (due to truncate-lines change above). + +2003-09-24 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp: + Support for stream redirection. + slime-output-stream: New structure. + (slime-out-misc): New function. + *slime-output*: New variable. + (read-from-emacs): Redirect output to *slime-output*. + (read-form): Bind *package* inside the standard-io-syntax macro. + (eval-string): Read the string with read-form. + (completions): Support for keyword completion. + + * slime.el (slime-process-available-input, slime-eval): Rewritten + once again. Don't use unwind-protect anymore. Didn't work + properly when the Lisp side aborted due to too many debug + levels. "Continuing" from the Emacs debugger aborts one level on + the Lisp side. "Quitting" from the Emacs debugger quits the Lisp + side too. Increase stack sizes before entering the recursive edit. + (slime-eval-async-state, slime-eval, sldb-state): Support for stream + output. + slime-last-output-start: New variable. + (slime-output-buffer, slime-output-buffer-position, + slime-insert-transcript-delimiter, slime-show-last-output, + slime-output-string): New functions. + (slime-show-evaluation-result, + slime-show-evaluation-result-continuation): Use them. + (slime-use-inf-lisp-p, slime-insert-transcript-delimiter, + slime-inferior-lisp-marker-position, + slime-inferior-lisp-show-last-output): Deleted. + (slime-use-tty-debugger, slime-debugger-hook, + slime-enter-tty-debugger, slime-tty-debugger-state): Deleted. Removed + tty debugger support. + (def-sldb-invoke-restart): Renamed. + (define-sldb-invoke-restart-key, define-sldb-invoke-restart-keys): + Version without eval. + (defun-if-undefined): New macro. + Many indentation fixes. + +2003-09-23 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * swank.lisp (completions): + Moved most of the completion code to Lisp. + (string-prefix-p): Be case insensitive. + + * slime.el: + Make sure define-minor-mode is defined before we use it. + (slime-completing-read-internal, slime-completing-read-symbol-name, + slime-read-from-minibuffer, slime-completions, slime-complete-symbol): + Support for reading symbols and expressions with completion. + (slime-read-symbol-name): New function. + (slime-read-symbol): Use it. + (slime-read-package-name): Case insensitive completion. + + (slime-edit-symbol-fdefinition, slime-edit-fdefinition): Rename + slime-edit-symbol-fdefinition to slime-edit-fdefinition. + +2003-09-23 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-show-xrefs): Improved the xrefs buffer, now + using a custom minor mode. + (slime-next-location): This function goes to the next "something" + by funcall'ing slime-next-location-function. Currently that + variable is set by xref commands like who-calls to go to the next + matching reference. In future it can also be used to go to the + next function definition for a generic-function-understanding + version of edit-fdefinition. Bound to C-M-. and C-c C-SPC, until + we see which binding is better. + +2003-09-22 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-symbol-at-point): Now returns a symbol, as the + name suggests. + (slime-symbol-name-at-point): This one returns a string. + (slime-read-symbol): New function for taking the symbol at point, + or prompting if there isn't one. + (slime-edit-fdefinition): Now uses looks up the symbol at point, + not the function being called at point. + + * swank.lisp (who-calls, who-references, who-binds, who-sets, + who-macroexpands): New function. + (present-symbol-before-p): Use `*buffer-package*' when checking + accessibility of symbols. + + * slime.el (slime-restore-window-configuration): New command to + put the Emacs window configuration back the way it was before + SLIME last changed it. + (slime-who-calls, etc): Very basic WHO-{CALLS,..} support. Not + finished, wrestling around trying to make `view-mode' or + `help-mode' help me (I just want to hijack RET and C-m). Bound to + "C-c C-w ...". + +2003-09-21 Luke Gorrie <luke(a)bluetail.com> + + * slime.el: Rearranged the `outline-mode' structure slightly. + (slime-check-connected): Using new function to give a helpful + error message if you try to use commands before establishing a + connection to CMUCL. + (sldb-mode): Keys 0-9 are now shortcuts to invoke restarts. + + * README, swank.el: Updated commentary. + +2003-09-20 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-choose-overlay-region): Tweaked overlay + placement. + + * swank.lisp (handle-notification): Skipping null + notifications. For some reason CMUCL occasionally calls us with + NIL as each argument. + +2003-09-19 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-connect): Propose default values when called + interactively. + (slime-process-available-input): If possible, use while rather than + recursion. + (slime-compilation-finished-continuation): New function. + (slime-compile-file, slime-compile-defun): Use it. + (slime-forward-source-path): Id an error is encounter move back to the + last valid point. + (slime-eval-region): Use append COND. Send the entire string to the + Lisp side and read&evaluate it there. + (slime-eval-buffer): New function. + (sldb-sugar-move, sldb-details-up, sldb-details-down): New functions. + + * swank.lisp (interactive-eval-region): New function. + (re-evaluate-defvar): New function. + (compile-defun): Install handler for compiler-errors. + (function-first-code-location): Simplified. + +2003-09-17 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-apropos-all): New command, bound to C-c M-a. + (slime-eval): Simplified. + (swank:arglist-string): Send a string and not a symbol. It easier + to package related thins in CL. + (slime-edit-symbol-fdefinition): Prompt when called with + prefix-argument. + (slime-eval-region): New function. + (slime-load-file): New function. + (slime-show-description): Set slime minor mode in Help buffer. + + * swank.lisp: (read-string, from-string): Renamed read-string to + from-string. + (to-string) New function. + (arglist-string): Catch reader errors. + (sldb-loop): Also bind *readstrable*. + + +2003-09-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el (slime-toggle-trace-fdefinition): New command. + (slime-symbol-at-point, slime-sexp-at-point): New utility functions. + (slime-edit-symbol-fdefinition): Similar to slime-edit-fdefinition but + uses swank:function-source-location-for-emacs. + (slime-goto-source-location): New function. + (sldb-show-source): Use it. + (slime-read-package-name): Completing read for package names. + (slime-apropos): Use it. + + * swank.lisp (function-source-location, + function-source-location-for-emacs): New functions to extract + source locations from compiled code. For struct-accessors we try + to find the source location of the corresponding constructor. + (list-all-package-names): New function. + (toggle-trace-fdefinition, tracedp): New functions. + +2003-09-15 Helmut Eller <e9626484(a)stud3.tuwien.ac.at> + + * slime.el: Moved many CL fragments from slime.el to swank.lisp. + (slime-compile-file, slime-compile-defun, slime-goto-location): + Compiler notes are now represented with a property list. To find + the source expression first move to the file offset of the + top-level form and then use the source path to find the + expression. This should avoid many reader issues. For + compile-defun store the start position of the top-level expression + from the buffer in the compiler notes and use that to locate error + messages. Add error overlays for notes without context to the + first available expression. + + * swank.lisp: Moved many CL fragments from slime.el to swank.lisp. + (defslimefun): New macro. + +2003-09-15 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-setup-command-hooks): Removed post-command-hook + that was used for cleaning up input that was unprocessed due to an + error breaking out of the process filter. This is now handled by + an `unwind-protect' in the filter. + + * swank.lisp (apropos-list-for-emacs): Hacked the apropos listing + to accept more options and to specially sort results. + + * slime.el (slime-net-send): Added newlines to messages over the + wire. This makes the protocol nicely readable in Ethereal. + (slime-sync): New function for blocking until asynchronous + requests are complete. + (slime-apropos): Hacked the apropos command: by default, only + external symbols are shown. With a prefix argument you have the + option to include internal symbols and to specify a package. + (slime-run-tests): Extended the test suite. Use `M-x + slime-run-tests' to run it. + +2003-09-14 Luke Gorrie <luke(a)bluetail.com> + + * slime.el, swank.lisp: Added the debugger written by Helmut. + + * cmucl-wire.el: Removed. The WIRE communication protocol has been + replaced by a simple custom TCP protocol based on READ/PRIN1 to + send sexps as ascii text. This simplifies the code, makes the + protocol nicely debugable with ethereal, and should ease porting + to other Lisps. Incremented TCP port number to 4005 in honor of + the new protocol. + + In addition, Lisp now always uses *print-case* of :DOWNCASE when + preparing sexps for Emacs. This is in reaction to a bug with Emacs + reading the empty list as `NIL' instead of `nil'. + + * slime.el (slime-net-connect): The Emacs end of the new + communication protocol. + + * swank.lisp (create-swank-server): The Lisp end of the new + communication protocol. + +2003-09-11 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-mode): Added Helmut's commands to the mode + description. + (slime-show-apropos): Setting `truncate-lines' to t in apropos + listings, to avoid line-wrapping on overly long descriptions. + (slime-run-tests): Added the beginnings of an automated test + suite. (This is most useful for testing cross-Emacsen + compatibility before releases.) + + * swank.lisp (symbol-external-p): Put back this function which was + lost in a merge. + +2003-09-10 Luke Gorrie <luke(a)bluetail.com> + + * slime.el, cmucl-wire.el, swank.lisp: Large patch from Helmut + Eller. Includes: apropos, describe, compile-defun, fully + asynchronous continuation-based wire interface, interactive + evaluation, and more. Very nice :-) + +2003-09-08 Luke Gorrie <luke(a)bluetail.com> + + * cmucl-wire.el (wire-symbol-name, wire-symbol-package): Fixed to + handle internal references (pkg::name). + + * slime.el (slime-swank-connection-retries): Increased default + number of connection retries from 5 to ten. + + * swank.lisp (find-fdefinition): Support for finding + function/macro definitions for Emacs. + + * slime.el: Indentation "cleanups": somehow I was using + `common-lisp-indent-function' for Emacs Lisp code previously. + (slime-edit-fdefinition): Added M-. (edit definition) and M-, (pop + definition stack) commands. Definitions are found in much the same + way Hemlock does it. The user-interface is not the same as TAGS, + because I like this one better. We can add TAGS-compatibility as + an optional feature in future. + +2003-09-04 Luke Gorrie <luke(a)bluetail.com> + + * slime.el (slime-completions): Now supports completing + package-internal symbols with "pkg::prefix" syntax. + + * Everything: imported slime-0.2 sources. + +;; Local Variables: +;; coding: latin-1 +;; End: + +This file has been placed in the public domain. Added: branches/trunk-reorg/thirdparty/slime/HACKING =================================================================== --- branches/trunk-reorg/thirdparty/slime/HACKING 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/HACKING 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,136 @@ +* The SLIME Hacker's Handbook -*- outline -*- + +* Lisp code file structure + +The Lisp code is organised into these files: + + swank-backend.lisp: + Definition of the interface to non-portable features. + Stand-alone. + + swank-<cmucl|...>.lisp: + Backend implementation for a specific Common Lisp system. + Uses swank-backend.lisp. + + swank.lisp: + The top-level server program, built from the other components. + Uses swank-backend.lisp as an interface to the actual backends. + +* ChangeLog + +For each change we make an entry in the ChangeLog file. This is +typically done using the command `add-change-log-entry-other-window' +(C-x 4 a). The message can be automatically extracted from the +ChangeLog to use in a CVS commit message by pressing C-c C-a in a +vc-mode or pcl-cvs commit buffer. + +ChangeLog diffs are automatically sent to the slime-devel mailing list +each day as a sort of digest summary of the slime-cvs list. + +There are good tips on writing ChangeLog entries in the GNU Coding Standards: + http://www.gnu.org/prep/standards_40.html#SEC40 + +For information about Emacs's ChangeLog support see the `Change Log' +and `Change Logs and VC' nodes of the Emacs manual: + http://www.gnu.org/software/emacs/manual/html_node/emacs_333.html#SEC333 + http://www.gnu.org/software/emacs/manual/html_node/emacs_156.html#SEC156 + +* Sending Patches + +If you would like to send us improvements you can create a patch with +C-x v = in the buffer or manually with 'cvs diff -u'. It's helpful if +you also include a ChangeLog entry describing your change. + +* Test Suite + +The Elisp code includes a command `slime-run-tests' to run a test +suite. This can give a pretty good sanity-check for your changes. + +Some backends do not pass the full test suite because of missing +features. In these cases the test suite is still useful to ensure that +changes don't introduce new errors. CMUCL historically passes the full +test suite so it makes a good sanity check for fundamental changes +(e.g. to the protocol). + +Running the test suite, adding new cases, and increasing the number of +cases that backends support are all very good for karma. + + +* Source code layout + +We use a special source file layout to take advantage of some fancy +Emacs features: outline-mode and "narrowing". + +** Outline structure + +Our source files have a hierarchical structure using comments like +these: + + ;;;; Heading + ;;;;; Subheading + ... etc + +We do this as a nice way to structure the program. We try to keep each +(sub)section small enough to fit in your head: typically around 50-200 +lines of code each. Each section usually begins with a brief +introduction, followed by its highest-level functions, followed by +their subroutines. This is a pleasing shape for a source file to have. + +Of course the comments mean something to Emacs too. One handy usage is +to bring up a hyperlinked "table of contents" for the source file +using this command: + + (defun show-outline-structure () + "Show the outline-mode structure of the current buffer." + (interactive) + (occur (concat "^" outline-regexp))) + +Another is to use `outline-minor-mode' to fold away certain parts of +the buffer. See the `Outline Mode' section of the Emacs manual for +details about that. + +(This file is also formatted for outline mode. If you're reading in +Emacs you can play around e.g. by pressing `C-c C-d' right now.) + +** Pagebreak characters (^L) + +We partition source files into chunks using pagebreak characters. Each +chunk is a substantial piece of code that can be considered in +isolation, that could perhaps be a separate source file if we were +fanatical about small source files (rather than big ones!) + +The page breaks usually go in the same place as top-level outline-mode +headings, but they don't have to. They're flexible. + +In the old days, when slime.el was less than 100 pages long, these +page breaks were helpful when printing it out to read. Now they're +useful for something else: narrowing. + +You can use `C-x n p' (narrow-to-page) to "zoom in" on a +pagebreak-delimited section of the file as if it were a separate +buffer in itself. You can then use `C-x n w' (widen) to "zoom out" and +see the whole file again. This is tremendously helpful for focusing +your attention on one part of the program as if it were its own file. + +(This file contains some page break characters. If you're reading in +Emacs you can press `C-x n p' to narrow to this page, and then later +`C-x n w' to make the whole buffer visible again.) + + +* Coding style + +We like the fact that each function in SLIME will fit on a single +screen (80x20), and would like to preserve this property! Beyond that +we're not dogmatic :-) + +In early discussions we all made happy noises about the advice in +Norvig and Pitman's _Tutorial on Good Lisp Programming Style_: + http://www.norvig.com/luv-slides.ps + +For Emacs Lisp, we try to follow the _Tips and Conventions_ in +Appendix D of the GNU Emacs Lisp Reference Manual (see Info file +`elisp', node `Tips'). + +Remember that to rewrite a program better is the sincerest form of +code appreciation. When you can see a way to rewrite a part of SLIME +better, please do so! Added: branches/trunk-reorg/thirdparty/slime/NEWS =================================================================== --- branches/trunk-reorg/thirdparty/slime/NEWS 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/NEWS 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,110 @@ +* SLIME News -*- outline -*- + +* 1.2 (March 2005) + +** New inspector +The lisp side now returns a specially formated list of "things" to +format which are then passed to emacs and rendered in the inspector +buffer. Things can be either text, recursivly inspectable values, or +functions to call. The new inspector has much better support CLOS +objects and methods. + +** Unicode +It's now possible to send non-ascii characters to Emacs, if the +communication channel is configured properly. See the variable +`slime-net-coding-system'. + +** Arglist lookup while debugging +Previously, arglist lookup was disabled while debugging. This +restriction was removed. + +** Extended tracing command +It's now possible to trace individual a single methods or all methods +of a generic function. Also tracing can be restricted to situations +in which the traced function is called from a specific function. + +** M-x slime-browse-classes +A simple class browser was added. + +** FASL files +The fasl files for different Lisp/OS/hardware combinations are now +placed in different directories. + +** Many other small improvements and bugfixes + +* 1.0 (September 2004) + +** slime-interrupt +The default key binding for slime-interrupt is now C-c C-b. + +** sldb-inspect-condition +In SLDB 'C' is now bound to sldb-inspect-condition. + +** More Menus +SLDB and the REPL have now pull-down menus. + +** Global debugger hook. +A new configurable *global-debugger* to control whether +swank-debugger-hook should be installed globally is available. True by +default. + +** When you call sldb-eval-in-frame with a prefix argument, the result is +now inserted in the REPL buffer. + +** Compile function +For Allegro M-. works now for functions compiled with C-c C-c. + +** slime-edit-definition +Better support for Allegro: works now for different type of +definitions not only. So M-. now works for e.g. classes in Allegro. + +** SBCL 0.8.13 +SBCL 0.8.12 is no longer supported. Support for 0.8.12 was broken for +for some time now. + +* 1.0 beta (August 2004) + +** autodoc global variables +The slime-autodoc-mode will now automatically show the value of a +global variable at point. + +** Customize group +The customize group is expanded and better-organised. + +** slime-interactive-eval +Interactive-eval commands now print their results to the REPL when +given a prefix argument. + +** slime-conservative-indentation +New Elisp variable. Non-nil means that we exclude def* and with-* from +indentation-learning. The default is t. + +** (slime-setup) +New function to streamline setup in ~/.emacs + +** Modeline package +The package name in the modeline is now updated on an idle timer. The +message should now be more meaningful when moving around in files +containing multiple IN-PACKAGE forms. + +** XREF bugfix +The XREF commands did not find symbols in the right package. + +** REPL prompt +The package name in the REPL's prompt is now abbreviated to the last +`.'-delimited token, e.g. MY.COMPANY.PACKAGE would be PACKAGE. This +can be disabled by setting SWANK::*AUTO-ABBREVIATE-DOTTED-PACKAGES* to +NIL. + +** CMUCL source cache +The source cache is now populated on `first-change-hook'. This makes +M-. work accurately in more file modification scenarios. + +** SBCL compiler errors +Detect compiler errors and make some noise. Previously certain +problems (e.g. reader-errors) could slip by quietly. + +* 1.0 alpha (June 2004) + +The first preview release of SLIME. + Added: branches/trunk-reorg/thirdparty/slime/PROBLEMS =================================================================== --- branches/trunk-reorg/thirdparty/slime/PROBLEMS 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/PROBLEMS 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,95 @@ +Known problems with SLIME -*- outline -*- + +* Common to all backends + +** Caution: network security +The `M-x slime' command has Lisp listen on a TCP socket and wait for +Emacs to connect, which typically takes on the order of one second. If +someone else were to connect to this socket then they could use the +SLIME protocol to control the Lisp process. + +The listen socket is bound on the loopback interface in all Lisps that +support this. This way remote hosts are unable to connect. + +** READ-CHAR-NO-HANG is broken + +READ-CHAR-NO-HANG doesn't work properly for slime-input-streams. Due +to the way we request input from Emacs it's not possible to repeatedly +poll for input. To get any input you have to call READ-CHAR (or a +function which calls READ-CHAR). + +* Backend-specific problems + +** CMUCL + +The default communication style :SIGIO is reportedly unreliable with +certain libraries (like libSDL) and certain platforms (like Solaris on +Sparc). It generally works very well on x86 so it remains the default. + +** SBCL + +The latest released version of SBCL at the time of packaging should +work. Older or newer SBCLs may or may not work. Do not use +multithreading with unpatched 2.4 Linux kernels. There are also +problems with kernel versions 2.6.5 - 2.6.10. + +The (v)iew-source command in the debugger can only locate exact source +forms for code compiled at (debug 2) or higher. The default level is +lower and SBCL itself is compiled at a lower setting. Thus only +defun-granularity is available with default policies. + +The XREF commands are not implemented. + +** OpenMCL + +We support OpenMCL 0.14.3. + +The XREF commands are not available. + +** LispWorks + +On Windows, SLIME hangs when calling foreign functions or certain +other functions. The reason for this problem is unknown. + +We only support latin1 encoding. (Unicode wouldn't be hard to add.) + +** Allegro CL + +Interrupting Allegro with C-c C-b can be slow. This is caused by the +a relatively large process-quantum: 2 seconds by default. Allegro +responds much faster if mp:*default-process-quantum* is set to 0.1. + +** CLISP + +We require version 2.33.2 or higher. We also require socket support, so +you may have to start CLISP with "clisp -K full". + +Under Windows, interrupting (with C-c C-b) doesn't work. Emacs sends +a SIGINT signal, but the signal is either ignored or CLISP exits +immediately. + +Function arguments and local variables aren't displayed properly in +the backtrace. Changes to CLISP's C code are needed to fix this +problem. Interpreted code is usually easer to debug. + +M-. (find-definition) only works if the fasl file is in the same +directory as the source file. + +The arglist doesn't include the proper names only "fake symbols" like +`arg1'. + +** Armed Bear Common Lisp + +The ABCL support is still new and experimental. + +** Corman Common Lisp + +We require version 2.51 or higher, with several patches (available at +http://www.grumblesmurf.org/lisp/corman-patches). + +The only communication style currently supported is NIL. + +Interrupting (with C-c C-b) doesn't work. + +The tracing, stepping and XREF commands are not implemented along with +some debugger functionality. Added: branches/trunk-reorg/thirdparty/slime/README =================================================================== --- branches/trunk-reorg/thirdparty/slime/README 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/README 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,41 @@ +Overview. +---------------------------------------- + + SLIME is the Superior Lisp Interaction Mode for Emacs. It is + implemented in two main parts: the Emacs Lisp side (slime.el), and + the support library for the Common Lisp (swank.lisp and swank-*.lisp) + + For a real description, see the manual in doc/ + +Quick setup instructions +------------------------ + + Add this to your ~/.emacs file and fill in the appropriate filenames: + + (add-to-list 'load-path "~/hacking/lisp/slime/") ; your SLIME directory + (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") ; your Lisp system + (require 'slime) + (slime-setup) + + Make sure your `inferior-lisp-program' is set to a compatible + version of Lisp. + + Use `M-x' slime to fire up and connect to an inferior Lisp. + SLIME will now automatically be available in your Lisp source + buffers. + +Licence. +---------------------------------------- + + SLIME is free software. All files, unless explicitly stated + otherwise, are public domain. + +Contact. +---------------------------------------- + + Questions and comments are best directed to the mailing list: + http://common-lisp.net/mailman/listinfo/slime-devel + + The mailing list archive is also available on Gmane: + http://news.gmane.org/gmane.lisp.slime.devel + Added: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,30 @@ +/ChangeLog/1.62/Mon Oct 1 13:37:22 2007// +/README/1.3/Fri Sep 28 13:05:44 2007// +/bridge.el/1.1/Wed Sep 19 11:47:03 2007// +/inferior-slime.el/1.2/Mon Sep 10 21:44:48 2007// +/slime-asdf.el/1.3/Fri Sep 21 12:44:13 2007// +/slime-autodoc.el/1.5/Mon Oct 1 13:37:10 2007// +/slime-banner.el/1.4/Thu Sep 20 14:55:53 2007// +/slime-c-p-c.el/1.8/Thu Sep 20 14:55:53 2007// +/slime-editing-commands.el/1.5/Thu Sep 20 14:55:53 2007// +/slime-fancy-inspector.el/1.2/Thu Sep 20 14:55:53 2007// +/slime-fancy.el/1.4/Fri Sep 28 13:05:35 2007// +/slime-fuzzy.el/1.4/Thu Sep 20 14:55:53 2007// +/slime-highlight-edits.el/1.3/Thu Sep 20 14:55:53 2007// +/slime-parse.el/1.7/Sat Sep 15 11:09:36 2007// +/slime-presentation-streams.el/1.2/Tue Aug 28 08:25:12 2007// +/slime-presentations.el/1.8/Thu Sep 20 14:55:53 2007// +/slime-references.el/1.4/Thu Sep 20 14:55:53 2007// +/slime-scratch.el/1.4/Thu Sep 20 14:55:53 2007// +/slime-tramp.el/1.2/Tue Sep 4 10:18:44 2007// +/slime-typeout-frame.el/1.5/Mon Oct 1 11:50:06 2007// +/slime-xref-browser.el/1.1/Fri Aug 24 14:47:11 2007// +/swank-arglists.lisp/1.10/Tue Sep 11 12:33:00 2007// +/swank-asdf.lisp/1.1/Tue Sep 4 10:32:07 2007// +/swank-c-p-c.lisp/1.2/Wed Sep 5 19:35:35 2007// +/swank-fancy-inspector.lisp/1.4/Thu Sep 20 14:55:53 2007// +/swank-fuzzy.lisp/1.6/Sat Sep 15 22:21:21 2007// +/swank-listener-hooks.lisp/1.1/Tue Aug 28 13:53:02 2007// +/swank-presentation-streams.lisp/1.4/Tue Aug 28 16:26:32 2007// +/swank-presentations.lisp/1.4/Tue Sep 4 09:49:10 2007// +D Added: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Repository 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Repository 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1 @@ +slime/contrib Added: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Root 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Root 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1 @@ +:pserver:anonymous:anonymous@common-lisp.net:/project/slime/cvsroot Added: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Template =================================================================== Added: branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,500 @@ +2007-10-01 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime-autdoc.el (slime-autodoc-message-ok-p): Don't display an + arglist when the minibuffer is active. + +2007-10-01 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime-typeout-frame.el: Messages in the typeout frame were too + easily overwritten by `slime-autodoc'. Fix that. + Reported by Geoff Wozniak. + + (slime-typeout-message-aux): Split out from `slime-typeout-message'. + (slime-typeout-message): Wrapper around it. Additionally disable + the autodoc timer temporarily. + +2007-09-30 Geoff Wozniak <geoff(a)wozniak.ca> + + * slime-typeout-frame.el (slime-typeout-frame-init): Fix quoted + FUNCTION forms in literal. + +2007-09-28 Tobias C. Rittweiler <tcr(a)freebits.de> + + * README: Updated. + + * slime-fancy.el: `slime-highlighting-edits' is not enabled by + default anymore, as its functionality is controversial, and it's + easier to explicitly enable it than to disable it once it got + globally activated. Better to be conservative. + + * slime-fancy.el: Not only load, but also enable `slime-scratch'. + +2007-09-21 Helmut Eller <heller(a)common-lisp.net> + + * slime-asdf.el (slime-asdf-init, slime-asdf-unload): Fix typos. + Reported by Ariel Badichi. + +2007-09-20 Helmut Eller <heller(a)common-lisp.net> + + Separate loading from initialization for many contribs. + + * slime-asdf.el + * slime-autodoc.el + * slime-banner.el + * slime-c-p-c.el + * slime-editing-commands.el + * slime-fancy-inspector.el + * slime-fuzzy.el + * slime-highlight-edits.el + * slime-presentations.el + * slime-references.el + * slime-scratch.el + * slime-typeout-frame.el + * swank-fancy-inspector.lisp + + * slime-fancy.el: As an exception, call the respective init + function when loading. + +2007-09-19 Helmut Eller <heller(a)common-lisp.net> + + * slime-c-p-c.el (slime-complete-symbol*-fancy): Move defcustom + from slime.el to contrib/slime-c-p-c.el. + +2007-09-16 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-fuzzy.lisp: Fix regression that would not allow to fuzzy + complete on inputs without package qualifier like "app". + Reported by David J. Neu. + + (%make-duplicate-symbols-filter): Return complement. + (fuzzy-find-matching-symbols): Treat passed filter as an acceptor + predicate, not as a rejector. + +2007-09-15 Helmut Eller <heller(a)common-lisp.net> + + Add the necessary hooks when loading some contribs, so that those + contribs can be easily loaded with slime-setup. + + * slime-highlight-edits.el (slime-highlight-edits-mode-on): New + function. Add this to slime-mode-hook by default. + + * slime-autodoc.el (slime-use-autodoc-mode): Change default to t. + +2007-09-15 Ariel Badichi <abadichi(a)bezeqint.net> + + * swank-fancy-inspector.lisp (inspect-for-emacs package): When + inspecting a package, the links in the use list and the used-by + list lead to inspecting package names, rather than the packages + themselves. Fix that. + +2007-09-15 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime-parse.el: Fix extended arglist display on misbalanced + expressions like `(defun foo | ... (defun bar () 'bar)' + Reported by Ariel Badichi. + + (slime-inside-string-p): Use `beginning-of-defun' directly than + relying on `slime-region-for-defun-at-point' (as this one uses + `end-of-defun' which signals an error on misbalanced expressions.) + +2007-09-15 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-fuzzy.lisp: Code reorganization and cleanup; making it + compute less and couple of other minor issues fixed on the + way. Thanks to Stelian Ionescu for testing and providing feedback! + + (defstruct fuzzy-matching): New `package-name' slot. + (make-fuzzy-matching): Updated for new slot. + (format-completion-result): Renamed to `fuzzy-format-matching'. + (%fuzzy-extract-matching-info): Helper for `fuzzy-format-matching'. + + (fuzzy-completion-set): Convert the matchings after they got + truncated to the passed completion-set limit from Emacs. + I.e. `slime-fuzzy-completion-limit' This means a huge + computational reduction. + + (fuzzy-create-completion-set): Renamed to `fuzzy-generate-matchings'. + (fuzzy-generate-matchings): Returns the fuzzy matchings + themselves, do not yet convert them for Emacs. Do not perform two + sorts on the generated matchings (first alphabetically, then per + score), but just one with an appropriate predicate that sorts per + score, unless matchings are equal, then sort alphabetically. Prune + matchings with symbols which are found in a differenta package + than their home package when the home package is among the matched + packages. Try to take the time needed to sort the generated + matchings into account for the time-limit. + (%guess-sort-duration): Helper. + Tries to guess how long the sort will take. + (%make-duplicate-symbols-filter): Helper. + Used for pruning of matchings. + (fuzzy-matching-greaterp): New testing predicate for sorting. + + (fuzzy-find-matching-symbols): Now takes a :filter keyarg; only + considers symbols that pass through the filter. + (fuzzy-find-matching-packages): Do not return matchings for all + nicknames of package, but just the one that matches best. + +2007-09-11 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime-editing-commands.el: Automatically bind the editing + commands when this module is required. (Previously, one had to + enable them explicitly, but this is inconsistent to, for instance, + the `slime-c-p-c' module which also sets up its bindings + automatically.) + (slime-bind-editing-commands): Renamed to `slime-editing-commands-init'. + (slime-editing-commands-init): Evaluated at toplevel. + +2007-09-11 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime-parse.el (slime-enclosing-form-specs): Now also works even + when point is inside a string. + (slime-inside-string-p): New function. + (slime-beginning-of-string): New function. + +2007-09-11 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-arglist.lisp (read-conversatively-for-autodoc): Also parse + quoted symbols explicitly. This fixed extended arglist display for + `(make-instance 'foo'. Reported by: Johannes Groedem. + +2007-09-11 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime-fancy.el: Require `slime-references'. + +2007-09-10 Helmut Eller <heller(a)common-lisp.net> + + * slime-parse.el (slime-cl-symbol-name, slime-cl-symbol-package): + Move from slime.el to contrib/slime-parse.el. + +2007-09-10 Helmut Eller <heller(a)common-lisp.net> + + * inferior-slime.el: Fix installation comment. + +2007-09-10 Helmut Eller <heller(a)common-lisp.net> + + Fix some of the bugs introduced with the last change. + + * slime-references.el (sldb-reference-face): Add missing quote. + (sldb-reference-properties): We are lucky and can use keywords + instead of strings. + (sldb-maybe-insert-references): Insert newlines differently. + +2007-09-10 Helmut Eller <heller(a)common-lisp.net> + + Move SBCL doc references to contrib. + + * slime-references.el: New file. + +2007-09-10 Attila Lendvai <attila.lendvai(a)gmail.com> + + * slime-fuzzy.el: Fixed some race condition that prevented a + proper closing of the *Fuzzy Completions* buffer in some + circumstances. + + (slime-fuzzy-save-window-configuration): Removed. Hooking up + `window-configuration-change-hook' via `run-with-timer' was racy + and lead to this bug; we now set the hook explicitely at the + necessary place instead. + (slime-fuzzy-window-configuration-change-add-hook): Removed. + (slime-fuzzy-choices-buffer): Explicitly save the + window-configuration, and explicitly set the hook. + (slime-fuzzy-done): Explicitely remove the hook. + +2007-09-10 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime-parse.el (slime-cl-symbol-name, slime-cl-symbol-package): + Moved back into slime.el. + +2007-09-08 Stelian Ionescu <sionescu(a)common-lisp.net> + + * slime-banner.el: Fixed typo to provide `slime-banner', not + `slime-startup-animation'. + +2007-09-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime-presentations.el (slime-presentation-write): Use case, not + ecase, for dispatching targets. Should fix XEmacs compatibility. + Reported by Steven E. Harris. + +2007-09-05 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-c-p-c.el: This file incorrectly provided the module + `:swank-compound-prefix'; changed that to `:swank-c-p-c'. + + This gets rid off the nasty redefinition warnings that were + previously signalled when loading SWANK with SBCL. + + * swank-arglist.lisp (arglist-for-echo-area): Locally declare + `*arglist-pprint-bindings*' to be special, as the variable is + defined later in the file. (Gets rid of warnings during loading.) + +2007-09-05 Tobias C. Rittweiler <tcr(a)freebits.de> + + * slime-c-p-c.el (slime-c-p-c-init): Bind `slime-complete-form' to + `C-c C-s' in `slime-repl-mode-map'. + +2007-09-05 Tobias C. Rittweiler <tcr(a)freebits.de> + + Added extended arglist display for DECLAIM and PROCLAIM. + + * slime-parse.el (slime-extended-operator-name-parser-alist): Added + entries for "DECLAIM", and "PROCLAIM". + (slime-parse-extended-operator/declare): Provide information about + the operator the arglist is requested for. + (slime-make-form-spec-from-string): Fixed for "()" as input. + + * swank-arglists.lisp (valid-operator-symbol-p): Explicitly allow + the symbol 'DECLARE. + (arglist-dispatch): New method for `DECLARE'. We have to catch + this explicitly, as DECLARE doesn't have an arglist (in the + `swank-backend:arglist' sense.) + (*arglist-pprint-bindings*): New variable. Splitted out from + `decoded-arglist-to-string'. + (decoded-arglist-to-string): Use `*arglist-pprint-bindings*'. + + (parse-first-valid-form-spec): Rewritten, because function + signature had to be changed: doesn't take arg-indices anymore; + returns position of first valid spec as second value to remedy. + (arglist-for-echo-area): Accomodated to new signature of + `parse-first-valid-form-spec'; now searchs for contextual + declaration operator name, to prefix a declaration arglist by + "declare", "declaim", or "proclaim" depending on what was used at + user's point in Slime. Use `*arglist-pprint-bindings*' for + printing the found declaration operator name. + (%find-declaration-operator): New helper to do this search. + (completions-for-keyword): Accomodated to new signature of + `parse-first-valid-form-spec'. Also fixed to correctly provide + keyword completions in nested expressions like: + + `(defun foo (x) + (let ((bar 'quux)) + (with-open-file (s f :|' [`|' being point] + +2007-09-04 Helmut Eller <heller(a)common-lisp.net> + + * swank-arglists.lisp (parse-first-valid-form-spec): Rewrite it for + ABCL. + +2007-09-04 Helmut Eller <heller(a)common-lisp.net> + + Some bug fixes for slime-complete-symbol*. + Patches by Mr. Madhu <enometh(a)meer.net> + + * slime-c-p-c.el (slime-c-p-c-unambiguous-prefix-p): New variable. + (slime-expand-abbreviations-and-complete): Use it. Also add a + workaround for XEmacs issues. + +2007-09-04 Helmut Eller <heller(a)common-lisp.net> + + Move asdf support to contrib: + + * slime-asdf.el: New file. + + * swank-asdf.lisp: New file + (operate-on-system, asdf-central-registry) + (list-all-systems-known-to-asdf): Use the asdf package in the + source code, i.e. write asdf:operate instead of + (find-symbol "OPERATE" "ASDF"). + +2007-09-04 Helmut Eller <heller(a)common-lisp.net> + + * slime-tramp.el: New file. + * slime-banner.el: New file. + * inferior-slime.el: New file. + +2007-09-01 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime-fancy.el: New meta-contrib. + +2007-09-01 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime-presentations.el (slime-dispatch-presentation-event): + Explicitly return t to indicate the events have been handled, + rather than relying on the return values of the called functions. + +2007-09-01 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime-typeout-frame.el (slime-typeout-autodoc-message): Fix for + messages that contain "%". Reported by Martin Simmons. + +2007-09-01 Tobias C. Rittweiler <tcr(a)freebits.de> + + Makes `slime-complete-form' work on `(eval-when |'; doesn't work + on `(eval-when (|' yet. + + * slime-parse.el (slime-parse-sexp-at-point): Guard against + `(char-after)' being NIL at end of buffer (especially important + for use on the REPL.) + + * swank-arglist.lisp (arglist-dispatch 'eval-when): Fix typo. + (print-decoded-arglist-as-template): Print keywords with PRIN1. + +2007-08-31 Tobias C. Rittweiler <tcr(a)freebits.de> + + Added extended arglist display for EVAL-WHEN, viz: + + (eval-when (&any :compile-toplevel :load-toplevel :execute) &body body) + + Notice that completion works as expected on these keywords. + + Die, EVAL-ALWAYS, die! + + * swank-arglist (arglist-dispatch): New method for EVAL-WHEN. + (print-arglist): Print keywords with PRIN1 rather than PRINC, + to get a result as shown above for the EVAL-WHEN case. + (completions-for-keyword): Add support for &ANY args. + +2007-08-31 Tobias C. Rittweiler <tcr(a)freebits.de> + + * swank-arglist.lisp: Do not fall back to READ when interpreting + the ``raw form specs'' comming from Slime's autodoc stuff. But + still do so for those comming from `slime-complete-form'. + + (unintern-in-home-package): New. + + (*arglist-dummy*): New. + (read-conversatively-for-autodoc): New function. Doesn't READ + anything that comes from Slime's autodoc. Just tries to parse + symbols. If that's not successfull, returns the dummy placeholder + datum stored in `*arglist-dummy*'. + (arglist-for-echo-area): Parse form-specs using + `read-conversatively-for-autodoc'. Use `unintern-in-home-package'. + + (read-softly): New. Splitted out from `read-form-spec'. This + function tries to keep track of newly interned functions before + READing. + (read-form-spec): Parametrized to take a function to read the + elements of the passed ``raw form spec''. Uses `read-softly' as + default reader. + + (complete-form, completions-for-keywords): + Use `unintern-in-home-package'. + +2007-08-31 Helmut Eller <heller(a)common-lisp.net> + + * slime-autodoc.el: Add installation notes. + * slime-editing-commands.el: Add installation notes. + * slime-c-p-c.el (slime-c-p-c-init): Fix typos. + +2007-08-31 Helmut Eller <heller(a)common-lisp.net> + + Move compound prefix completion and autodoc to contrib. + Interdependencies made it almost necessary to move parsing code + and editing commands in the same patch. + + * slime-c-p-c.el: New file. + * swank-c-p-c.el: New file. + * slime-parse.el: New file. + * swank-arglists.el: New file. + * slime-editing-commands.el: New file. + * slime-autodoc.el: New file. + +2007-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * slime-presentations.el (slime-last-output-target-id) + (slime-output-target-to-marker, slime-output-target-marker) + (slime-redirect-trace-output): Moved back into SLIME core. + + * swank-presentation-streams.lisp: Require swank-presentations. + (present-repl-results-via-presentation-streams): New. + (*send-repl-results-function*): Set this variable rather than + overriding send-repl-results-to-emacs. + +2007-08-28 Helmut Eller <heller(a)common-lisp.net> + + * slime-presentations.el (slime-clear-presentations): New + function. Add it to slime-repl-clear-buffer-hook. + +2007-08-28 Helmut Eller <heller(a)common-lisp.net> + + * swank-listener-hooks.lisp: New file + +2007-08-28 Helmut Eller <heller(a)common-lisp.net> + + Move the rest of the presentation related code. + + * swank-presentations.lisp (present-repl-results): Renamed from + send-repl-results-to-emacs. + +2007-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank-presentations.lisp (send-repl-results-to-emacs): + Override core defun to mark up REPL results as presentations. + + * swank-presentations.lisp: New file. + * slime-presentations.el: Load it. + + * slime-presentations.el (slime-presentation-write): Remove id + argument. + + * slime-presentation-streams.el: Require slime-presentations contrib. + +2007-08-27 Helmut Eller <heller(a)common-lisp.net> + + Move presentations to contrib. (ELisp part) + + * slime-presentations.el: New file. + * slime-scratch.el (slime-scratch-buffer): Ignore presentations. + +2007-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Some fixes to the presentation-streams contrib. + + * swank-presentation-streams.lisp [sbcl]: Load the pretty-printer + patch only at load time. Add some trickery so that SBCL does not + complain about the changed layout of the pretty-stream class. + + * swank-presentation-streams.lisp (slime-stream-p): Using special + return values, indicate whether we are printing to the + REPL-results stream, or a dedicated stream. + (presentation-record): New slot "target". + (presentation-start, presentation-end): Use it (rather than the + global variable *use-dedicated-output-stream*) to decide whether + to use the bridge protocol or the :presentation-start/-end + protocol. Also use it as the TARGET argument of + :presentation-start/-end messages. + (presenting-object-1): Use the new return values of + slime-stream-p. + + * swank-presentation-streams.lisp (slime-stream-p) [cmu]: Use the + return value of slime-stream-p rather than the global variable + *use-dedicated-output-stream* to decide whether printing through + pretty streams is safe for the layout. + +2007-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Make the fancy "presentation streams" feature a contrib. + Previously, it was only available if "present.lisp" was loaded + manually. + + * slime-presentation-streams.el: New file. + * swank-presentation-streams.lisp: New file, moved here from + ../present.lisp + +2007-08-24 Helmut Eller <heller(a)common-lisp.net> + + * slime-typeout-frame.el: New file. + * slime-xref-browser.el: New file. + * slime-highlight-edits.el: New file. + * slime-scratch.el: New file. + +2007-08-23 Helmut Eller <heller(a)common-lisp.net> + + Move Marco Baringer's inspector to contrib. + + * swank-fancy-inspector.lisp: New file. The only difference to the + code is that inspect-for-emacs methods in this file are + specialized to the new class `fancy-inspector'. + (fancy-inspector): New class. + + * slime-fancy-inspector.el: New file. + +2007-08-19 Helmut Eller <heller(a)common-lisp.net> + + Moved fuzzy completion code to contrib directory. + + * slime-fuzzy.el: New file. + (slime-fuzzy-init): New function. Load CL code on startup. + + * swank-fuzzy.lisp: New file. Common Lisp code for fuzzy + completion. Added: branches/trunk-reorg/thirdparty/slime/contrib/README =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/README 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/README 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,30 @@ +This directory contains source code which may be useful to some Slime +users. *.el files are Emacs Lisp source and *.lisp files contain +Common Lisp source code. If not otherwise stated in the file itself, +the files are placed in the Public Domain. + +The components in this directory are more or less detached from the +rest of Slime. They are essentially "add-ons". But Slime can also be +used without them. The code is maintained by the respective authors. + +To use the packages here, you should add this directory to your Emacs +load-path, require the contrib, and call the contrib's init function to +enable the functionality that's provided by the respective contrib. + +E.g. for fuzzy completion add this to your .emacs: + + (add-to-list 'load-path "<this-directory>") + (add-hook 'slime-load-hook (lambda () (require 'slime-fuzzy) + (slime-fuzzy-init))) + +Alternatively, you can use the `slime-setup' function which takes a +list of contrib names, and which loads and enables them automatically +for you: + + (slime-setup '(slime-fancy slime-asdf slime-tramp ...)) + + +Finally, the contrib `slime-fancy' is specially noteworthy, as it +represents a meta-contrib that'll load a bunch of commonly used +contribs. Look into `slime-fancy.el' to find out which. + \ No newline at end of file Added: branches/trunk-reorg/thirdparty/slime/contrib/bridge.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/bridge.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/bridge.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,467 @@ +;;; -*-Emacs-Lisp-*- +;;;%Header +;;; Bridge process filter, V1.0 +;;; Copyright (C) 1991 Chris McConnell, ccm(a)cs.cmu.edu +;;; +;;; Send mail to ilisp(a)cons.org if you have problems. +;;; +;;; Send mail to majordomo(a)cons.org if you want to be on the +;;; ilisp mailing list. + +;;; This file is part of GNU Emacs. + +;;; GNU Emacs is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY. No author or distributor +;;; accepts responsibility to anyone for the consequences of using it +;;; or for whether it serves any particular purpose or works at all, +;;; unless he says so in writing. Refer to the GNU Emacs General Public +;;; License for full details. + +;;; Everyone is granted permission to copy, modify and redistribute +;;; GNU Emacs, but only under the conditions described in the +;;; GNU Emacs General Public License. A copy of this license is +;;; supposed to have been given to you along with GNU Emacs so you +;;; can know your rights and responsibilities. It should be in a +;;; file named COPYING. Among other things, the copyright notice +;;; and this notice must be preserved on all copies. + +;;; Send any bugs or comments. Thanks to Todd Kaufmann for rewriting +;;; the process filter for continuous handlers. + +;;; USAGE: M-x install-bridge will add a process output filter to the +;;; current buffer. Any output that the process does between +;;; bridge-start-regexp and bridge-end-regexp will be bundled up and +;;; passed to the first handler on bridge-handlers that matches the +;;; output using string-match. If bridge-prompt-regexp shows up +;;; before bridge-end-regexp, the bridge will be cancelled. If no +;;; handler matches the output, the first symbol in the output is +;;; assumed to be a buffer name and the rest of the output will be +;;; sent to that buffer's process. This can be used to communicate +;;; between processes or to set up two way interactions between Emacs +;;; and an inferior process. + +;;; You can write handlers that process the output in special ways. +;;; See bridge-send-handler for the default handler. The command +;;; hand-bridge is useful for testing. Keep in mind that all +;;; variables are buffer local. + +;;; YOUR .EMACS FILE: +;;; +;;; ;;; Set up load path to include bridge +;;; (setq load-path (cons "/bridge-directory/" load-path)) +;;; (autoload 'install-bridge "bridge" "Install a process bridge." t) +;;; (setq bridge-hook +;;; '(lambda () +;;; ;; Example options +;;; (setq bridge-source-insert nil) ;Don't insert in source buffer +;;; (setq bridge-destination-insert nil) ;Don't insert in dest buffer +;;; ;; Handle copy-it messages yourself +;;; (setq bridge-handlers +;;; '(("copy-it" . my-copy-handler))))) + +;;; EXAMPLE: +;;; # This pipes stdin to the named buffer in a Unix shell +;;; alias devgnu '(echo -n "\!* "; cat -; echo -n "")' +;;; +;;; ls | devgnu *scratch* + +(eval-when-compile + (require 'cl)) + +;;;%Parameters +(defvar bridge-hook nil + "Hook called when a bridge is installed by install-hook.") + +(defvar bridge-start-regexp "" + "*Regular expression to match the start of a process bridge in +process output. It should be followed by a buffer name, the data to +be sent and a bridge-end-regexp.") + +(defvar bridge-end-regexp "" + "*Regular expression to match the end of a process bridge in process +output.") + +(defvar bridge-prompt-regexp nil + "*Regular expression for detecting a prompt. If there is a +comint-prompt-regexp, it will be initialized to that. A prompt before +a bridge-end-regexp will stop the process bridge.") + +(defvar bridge-handlers nil + "Alist of (regexp . handler) for handling process output delimited +by bridge-start-regexp and bridge-end-regexp. The first entry on the +list whose regexp matches the output will be called on the process and +the delimited output.") + +(defvar bridge-source-insert t + "*T to insert bridge input in the source buffer minus delimiters.") + +(defvar bridge-destination-insert t + "*T for bridge-send-handler to insert bridge input into the +destination buffer minus delimiters.") + +(defvar bridge-chunk-size 512 + "*Long inputs send to comint processes are broken up into chunks of +this size. If your process is choking on big inputs, try lowering the +value.") + +;;;%Internal variables +(defvar bridge-old-filter nil + "Old filter for a bridged process buffer.") + +(defvar bridge-string nil + "The current output in the process bridge.") + +(defvar bridge-in-progress nil + "The current handler function, if any, that bridge passes strings on to, +or nil if none.") + +(defvar bridge-leftovers nil + "Because of chunking you might get an incomplete bridge signal - start but the end is in the next packet. Save the overhanging text here.") + +(defvar bridge-send-to-buffer nil + "The buffer that the default bridge-handler (bridge-send-handler) is +currently sending to, or nil if it hasn't started yet. Your handler +function can use this variable also.") + +(defvar bridge-last-failure () + "Last thing that broke the bridge handler. First item is function call +(eval'able); last item is error condition which resulted. This is provided +to help handler-writers in their debugging.") + +;;;%Utilities +(defun bridge-insert (output) + "Insert process OUTPUT into the current buffer." + (if output + (let* ((buffer (current-buffer)) + (process (get-buffer-process buffer)) + (mark (process-mark process)) + (window (selected-window)) + (at-end nil)) + (if (eq (window-buffer window) buffer) + (setq at-end (= (point) mark)) + (setq window (get-buffer-window buffer))) + (save-excursion + (goto-char mark) + (insert output) + (set-marker mark (point))) + (if window + (progn + (if at-end (goto-char mark)) + (if (not (pos-visible-in-window-p (point) window)) + (let ((original (selected-window))) + (save-excursion + (select-window window) + (recenter '(center)) + (select-window original))))))))) + +;;; +;(defun bridge-send-string (process string) +; "Send PROCESS the contents of STRING as input. +;This is equivalent to process-send-string, except that long input strings +;are broken up into chunks of size comint-input-chunk-size. Processes +;are given a chance to output between chunks. This can help prevent processes +;from hanging when you send them long inputs on some OS's." +; (let* ((len (length string)) +; (i (min len bridge-chunk-size))) +; (process-send-string process (substring string 0 i)) +; (while (< i len) +; (let ((next-i (+ i bridge-chunk-size))) +; (accept-process-output) +; (process-send-string process (substring string i (min len next-i))) +; (setq i next-i))))) + +;;; +(defun bridge-call-handler (handler proc string) + "Funcall HANDLER on PROC, STRING carefully. Error is caught if happens, +and user is signaled. State is put in bridge-last-failure. Returns t if +handler executed without error." + (let ((inhibit-quit nil) + (failed nil)) + (condition-case err + (funcall handler proc string) + (error + (ding) + (setq failed t) + (message "bridge-handler \"%s\" failed %s (see bridge-last-failure)" + handler err) + (setq bridge-last-failure + (` ((funcall '(, handler) '(, proc) (, string)) + "Caused: " + (, err)))))) + (not failed))) + +;;;%Handlers +(defun bridge-send-handler (process input) + "Send PROCESS INPUT to the buffer name found at the start of the +input. The input after the buffer name is sent to the buffer's +process if it has one. If bridge-destination-insert is T, the input +will be inserted into the buffer. If it does not have a process, it +will be inserted at the end of the buffer." + (if (null input) + (setq bridge-send-to-buffer nil) ; end of bridge + (let (buffer-and-start buffer-name dest to) + ;; if this is first time, get the buffer out of the first line + (cond ((not bridge-send-to-buffer) + (setq buffer-and-start (read-from-string input) + buffer-name (format "%s" (car (read-from-string input))) + dest (get-buffer buffer-name) + to (get-buffer-process dest) + input (substring input (cdr buffer-and-start))) + (setq bridge-send-to-buffer dest)) + (t + (setq buffer-name bridge-send-to-buffer + dest (get-buffer buffer-name) + to (get-buffer-process dest) + ))) + (if dest + (let ((buffer (current-buffer))) + (if bridge-destination-insert + (unwind-protect + (progn + (set-buffer dest) + (if to + (bridge-insert process input) + (goto-char (point-max)) + (insert input))) + (set-buffer buffer))) + (if to + ;; (bridge-send-string to input) + (process-send-string to input) + )) + (error "%s is not a buffer" buffer-name))))) + +;;;%Filter +(defun bridge-filter (process output) + "Given PROCESS and some OUTPUT, check for the presence of +bridge-start-regexp. Everything prior to this will be passed to the +normal filter function or inserted in the buffer if it is nil. The +output up to bridge-end-regexp will be sent to the first handler on +bridge-handlers that matches the string. If no handlers match, the +input will be sent to bridge-send-handler. If bridge-prompt-regexp is +encountered before the bridge-end-regexp, the bridge will be cancelled." + (let ((inhibit-quit t) + (match-data (match-data)) + (buffer (current-buffer)) + (process-buffer (process-buffer process)) + (case-fold-search t) + (start 0) (end 0) + function + b-start b-start-end b-end) + (set-buffer process-buffer) ;; access locals + + ;; Handle bridge messages that straddle a packet by prepending + ;; them to this packet. + + (when bridge-leftovers + (setq output (concat bridge-leftovers output)) + (setq bridge-leftovers nil)) + + (setq function bridge-in-progress) + + ;; How it works: + ;; + ;; start, end delimit the part of string we are interested in; + ;; initially both 0; after an iteration we move them to next string. + + ;; b-start, b-end delimit part of string to bridge (possibly whole string); + ;; this will be string between corresponding regexps. + + ;; There are two main cases when we come into loop: + + ;; bridge in progress + ;;0 setq b-start = start + ;;1 setq b-end (or end-pattern end) + ;;4 process string + ;;5 remove handler if end found + + ;; no bridge in progress + ;;0 setq b-start if see start-pattern + ;;1 setq b-end if bstart to (or end-pattern end) + ;;2 send (substring start b-start) to normal place + ;;3 find handler (in b-start, b-end) if not set + ;;4 process string + ;;5 remove handler if end found + + ;; equivalent sections have the same numbers here; + ;; we fold them together in this code. + + (block bridge-filter + (unwind-protect + (while (< end (length output)) + + ;;0 setq b-start if find + (setq b-start + (cond (bridge-in-progress + (setq b-start-end start) + start) + ((string-match bridge-start-regexp output start) + (setq b-start-end (match-end 0)) + (match-beginning 0)) + (t nil))) + ;;1 setq b-end + (setq b-end + (if b-start + (let ((end-seen (string-match bridge-end-regexp + output b-start-end))) + (if end-seen (setq end (match-end 0))) + + end-seen))) + + ;; Detect and save partial bridge messages + (when (and b-start b-start-end (not b-end)) + (setq bridge-leftovers (substring output b-start)) + ) + + (if (and b-start (not b-end)) + (setq end b-start) + (if (not b-end) + (setq end (length output)))) + + ;;1.5 - if see prompt before end, remove current + (if (and b-start b-end) + (let ((prompt (string-match bridge-prompt-regexp + output b-start-end))) + (if (and prompt (<= (match-end 0) b-end)) + (setq b-start nil ; b-start-end start + b-end start + end (match-end 0) + bridge-in-progress nil + )))) + + ;;2 send (substring start b-start) to old filter, if any + (when (not (equal start (or b-start end))) ; don't bother on empty string + (let ((pass-on (substring output start (or b-start end)))) + (if bridge-old-filter + (let ((old bridge-old-filter)) + (store-match-data match-data) + (funcall old process pass-on) + ;; if filter changed, re-install ourselves + (let ((new (process-filter process))) + (if (not (eq new 'bridge-filter)) + (progn (setq bridge-old-filter new) + (set-process-filter process 'bridge-filter))))) + (set-buffer process-buffer) + (bridge-insert pass-on)))) + + (if (and b-start-end (not b-end)) + (return-from bridge-filter t) ; when last bit has prematurely ending message, exit early. + (progn + ;;3 find handler (in b-start, b-end) if none current + (if (and b-start (not bridge-in-progress)) + (let ((handlers bridge-handlers)) + (while (and handlers (not function)) + (let* ((handler (car handlers)) + (m (string-match (car handler) output b-start-end))) + (if (and m (< m b-end)) + (setq function (cdr handler)) + (setq handlers (cdr handlers))))) + ;; Set default handler if none + (if (null function) + (setq function 'bridge-send-handler)) + (setq bridge-in-progress function))) + ;;4 process strin + (if function + (let ((ok t)) + (if (/= b-start-end b-end) + (let ((send (substring output b-start-end b-end))) + ;; also, insert the stuff in buffer between + ;; iff bridge-source-insert. + (if bridge-source-insert (bridge-insert send)) + ;; call handler on string + (setq ok (bridge-call-handler function process send)))) + ;;5 remove handler if end found + ;; if function removed then tell it that's all + (if (or (not ok) (/= b-end end)) ;; saw end before end-of-string + (progn + (bridge-call-handler function process nil) + ;; have to remove function too for next time around + (setq function nil + bridge-in-progress nil) + )) + )) + + ;; continue looping, in case there's more string + (setq start end)) + )) + ;; protected forms: restore buffer, match-data + (set-buffer buffer) + (store-match-data match-data) + )))) + + +;;;%Interface +(defun install-bridge () + "Set up a process bridge in the current buffer." + (interactive) + (if (not (get-buffer-process (current-buffer))) + (error "%s does not have a process" (buffer-name (current-buffer))) + (make-local-variable 'bridge-start-regexp) + (make-local-variable 'bridge-end-regexp) + (make-local-variable 'bridge-prompt-regexp) + (make-local-variable 'bridge-handlers) + (make-local-variable 'bridge-source-insert) + (make-local-variable 'bridge-destination-insert) + (make-local-variable 'bridge-chunk-size) + (make-local-variable 'bridge-old-filter) + (make-local-variable 'bridge-string) + (make-local-variable 'bridge-in-progress) + (make-local-variable 'bridge-send-to-buffer) + (make-local-variable 'bridge-leftovers) + (setq bridge-string nil bridge-in-progress nil + bridge-send-to-buffer nil) + (if (boundp 'comint-prompt-regexp) + (setq bridge-prompt-regexp comint-prompt-regexp)) + (let ((process (get-buffer-process (current-buffer)))) + (if process + (if (not (eq (process-filter process) 'bridge-filter)) + (progn + (setq bridge-old-filter (process-filter process)) + (set-process-filter process 'bridge-filter))) + (error "%s does not have a process" + (buffer-name (current-buffer))))) + (run-hooks 'bridge-hook) + (message "Process bridge is installed"))) + +;;; +(defun reset-bridge () + "Must be called from the process's buffer. Removes any active bridge." + (interactive) + ;; for when things get wedged + (if bridge-in-progress + (unwind-protect + (funcall bridge-in-progress (get-buffer-process + (current-buffer)) + nil) + (setq bridge-in-progress nil)) + (message "No bridge in progress."))) + +;;; +(defun remove-bridge () + "Remove bridge from the current buffer." + (interactive) + (let ((process (get-buffer-process (current-buffer)))) + (if (or (not process) (not (eq (process-filter process) 'bridge-filter))) + (error "%s has no bridge" (buffer-name (current-buffer))) + ;; remove any bridge-in-progress + (reset-bridge) + (set-process-filter process bridge-old-filter) + (funcall bridge-old-filter process bridge-string) + (message "Process bridge is removed.")))) + +;;;% Utility for testing +(defun hand-bridge (start end) + "With point at bridge-start, sends bridge-start + string + +bridge-end to bridge-filter. With prefix, use current region to send." + (interactive "r") + (let ((p0 (if current-prefix-arg (min start end) + (if (looking-at bridge-start-regexp) (point) + (error "Not looking at bridge-start-regexp")))) + (p1 (if current-prefix-arg (max start end) + (if (re-search-forward bridge-end-regexp nil t) + (point) (error "Didn't see bridge-end-regexp"))))) + + (bridge-filter (get-buffer-process (current-buffer)) + (buffer-substring-no-properties p0 p1)) + )) + +(provide 'bridge) Added: branches/trunk-reorg/thirdparty/slime/contrib/inferior-slime.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/inferior-slime.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/inferior-slime.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,88 @@ +;;; inferior-slime.el --- Minor mode with Slime keys for comint buffers +;; +;; Author: Luke Gorrie <luke(a)synap.se> +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'inferior-slime))) +;; (add-hook 'inferior-lisp-mode-hook (lambda () (inferior-slime-mode 1))) + +(define-minor-mode inferior-slime-mode + "\\<slime-mode-map>\ +Inferior SLIME mode: The Inferior Superior Lisp Mode for Emacs. + +This mode is intended for use with `inferior-lisp-mode'. It provides a +subset of the bindings from `slime-mode'. + +\\{inferior-slime-mode-map}" + nil + nil + ;; Fake binding to coax `define-minor-mode' to create the keymap + '((" " 'undefined))) + +(add-to-list 'minor-mode-alist + '(inferior-slime-mode + (" Inf-Slime" slime-state-name))) + +(defun inferior-slime-return () + "Handle the return key in the inferior-lisp buffer. +The current input should only be sent if a whole expression has been +entered, i.e. the parenthesis are matched. + +A prefix argument disables this behaviour." + (interactive) + (if (or current-prefix-arg (inferior-slime-input-complete-p)) + (comint-send-input) + (insert "\n") + (inferior-slime-indent-line))) + +(defun inferior-slime-indent-line () + "Indent the current line, ignoring everything before the prompt." + (interactive) + (save-restriction + (let ((indent-start + (save-excursion + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (let ((inhibit-field-text-motion t)) + (beginning-of-line 1)) + (point)))) + (narrow-to-region indent-start (point-max))) + (lisp-indent-line))) + +(defun inferior-slime-input-complete-p () + "Return true if the input is complete in the inferior lisp buffer." + (slime-input-complete-p (process-mark (get-buffer-process (current-buffer))) + (point-max))) + +(defun inferior-slime-closing-return () + "Send the current expression to Lisp after closing any open lists." + (interactive) + (goto-char (point-max)) + (save-restriction + (narrow-to-region (process-mark (get-buffer-process (current-buffer))) + (point-max)) + (while (ignore-errors (save-excursion (backward-up-list 1) t)) + (insert ")"))) + (comint-send-input)) + +(defun inferior-slime-init-keymap () + (let ((map inferior-slime-mode-map)) + (define-key map [return] 'inferior-slime-return) + (define-key map [(control return)] 'inferior-slime-closing-return) + (define-key map [(meta control ?m)] 'inferior-slime-closing-return) + (define-key map "\C-c\C-d" slime-doc-map) + (define-key map "\C-c\C-w" slime-who-map) + (loop for (key command . keys) in slime-keys do + (destructuring-bind (&key prefixed inferior &allow-other-keys) keys + (when prefixed + (setq key (concat slime-prefix-key key))) + (when inferior + (define-key map key command)))))) + +(inferior-slime-init-keymap) + +(provide 'inferior-slime) Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-asdf.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-asdf.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-asdf.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,113 @@ +;;; slime-asdf.el -- ASDF support +;; +;; Authors: Daniel Barlow <dan(a)telent.net> +;; Marco Baringer <mb(a)bese.it> +;; Edi Weitz <edi(a)agharta.de> +;; and others +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path ".../slime/contrib") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-asdf))) +;; + +;; NOTE: `system-name' is a predefined variable in Emacs. Try to +;; avoid it as local variable name. + + +(defun slime-load-system (&optional system) + "Compile and load an ASDF system. + +Default system name is taken from first file matching *.asd in current +buffer's working directory" + (interactive (list (slime-read-system-name))) + (slime-oos system "LOAD-OP")) + +(defvar slime-system-history nil + "History list for ASDF system names.") + +(defun slime-read-system-name (&optional prompt initial-value) + "Read a system name from the minibuffer, prompting with PROMPT." + (setq prompt (or prompt "System: ")) + (let* ((completion-ignore-case nil) + (system-names (slime-eval `(swank:list-asdf-systems))) + (alist (slime-bogus-completion-alist system-names))) + (completing-read prompt alist nil nil + (or initial-value (slime-find-asd system-names) "") + 'slime-system-history))) + +(defun slime-find-asd (system-names) + "Tries to find an ASDF system definition in the default +directory or in the directory belonging to the current buffer and +returns it if it's in `system-names'." + (let* ((asdf-systems-in-directory + (mapcar #'file-name-sans-extension + (directory-files + (file-name-directory (or default-directory + (buffer-file-name))) + nil "\.asd$")))) + (loop for system in asdf-systems-in-directory + for candidate = (file-name-sans-extension system) + when (find candidate system-names :test #'string-equal) + do (return candidate)))) + +(defun slime-oos (system operation &rest keyword-args) + (slime-save-some-lisp-buffers) + (slime-display-output-buffer) + (message "Performing ASDF %S%s on system %S" + operation (if keyword-args (format " %S" keyword-args) "") + system) + (slime-eval-async + `(swank:operate-on-system-for-emacs ,system ,operation ,@keyword-args) + (slime-make-compilation-finished-continuation (current-buffer)))) + +(defslime-repl-shortcut slime-repl-load/force-system ("force-load-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) "LOAD-OP" :force t))) + (:one-liner "Recompile and load an ASDF system.")) + +(defslime-repl-shortcut slime-repl-load-system ("load-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) "LOAD-OP"))) + (:one-liner "Compile (as needed) and load an ASDF system.")) + +(defslime-repl-shortcut slime-repl-test/force-system ("force-test-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) "TEST-OP" :force t))) + (:one-liner "Compile (as needed) and force test an ASDF system.")) + +(defslime-repl-shortcut slime-repl-test-system ("test-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) "TEST-OP"))) + (:one-liner "Compile (as needed) and test an ASDF system.")) + +(defslime-repl-shortcut slime-repl-compile-system ("compile-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) "COMPILE-OP"))) + (:one-liner "Compile (but not load) an ASDF system.")) + +(defslime-repl-shortcut slime-repl-compile/force-system + ("force-compile-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) "COMPILE-OP" :force t))) + (:one-liner "Recompile (but not load) an ASDF system.")) + +(defun slime-asdf-on-connect () + (slime-eval-async '(swank:swank-require :swank-asdf))) + +(defun slime-asdf-init () + (add-hook 'slime-connected-hook 'slime-asdf-on-connect)) + +(defun slime-asdf-unload () + (remove-hook 'slime-connected-hook 'slime-asdf-on-connect)) + +(provide 'slime-asdf) Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,273 @@ +;;; slime-autodoc.el --- show fancy arglist in echo area +;; +;; Authors: Luke Gorrie <luke(a)bluetail.com> +;; Lawrence Mitchell <wence(a)gmx.li> +;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> +;; Tobias C. Rittweiler <tcr(a)freebits.de> +;; and others +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-autodoc))) +;; + +(require 'slime-parse) + +(defvar slime-use-autodoc-mode t + "When non-nil always enable slime-autodoc-mode in slime-mode.") + +(defun slime-fontify-string (string) + "Fontify STRING as `font-lock-mode' does in Lisp mode." + (with-current-buffer (get-buffer-create " *slime-fontify*") + (erase-buffer) + (if (not (eq major-mode 'lisp-mode)) + (lisp-mode)) + (insert string) + (let ((font-lock-verbose nil)) + (font-lock-fontify-buffer)) + (goto-char (point-min)) + (when (re-search-forward "===> \$\\(.\\|\n\$*\\) <===" nil t) + (let ((highlight (match-string 1))) + ;; Can't use (replace-match highlight) here -- broken in Emacs 21 + (delete-region (match-beginning 0) (match-end 0)) + (slime-insert-propertized '(face highlight) highlight))) + (buffer-substring (point-min) (point-max)))) + +(defun slime-arglist (name) + "Show the argument list for NAME." + (interactive (list (slime-read-symbol-name "Arglist of: "))) + (slime-eval-async + `(swank:arglist-for-echo-area (quote (,name))) + (lambda (arglist) + (if arglist + (message "%s" (slime-fontify-string arglist)) + (error "Arglist not available"))))) + + + +;;;; Autodocs (automatic context-sensitive help) + +(defvar slime-autodoc-mode nil + "*When non-nil, print documentation about symbols as the point moves.") + +(defvar slime-autodoc-cache-type 'last + "*Cache policy for automatically fetched documentation. +Possible values are: + nil - none. + last - cache only the most recently-looked-at symbol's documentation. + The values are stored in the variable `slime-autodoc-cache'. + +More caching means fewer calls to the Lisp process, but at the risk of +using outdated information.") + +(defvar slime-autodoc-cache nil + "Cache variable for when `slime-autodoc-cache-type' is 'last'. +The value is (SYMBOL-NAME . DOCUMENTATION).") + +(defun slime-autodoc-mode (&optional arg) + "Enable `slime-autodoc'." + (interactive "P") + (cond ((< (prefix-numeric-value arg) 0) (setq slime-autodoc-mode nil)) + (arg (setq slime-autodoc-mode t)) + (t (setq slime-autodoc-mode (not slime-autodoc-mode)))) + (if slime-autodoc-mode + (progn + (slime-autodoc-start-timer) + (add-hook 'pre-command-hook + 'slime-autodoc-pre-command-refresh-echo-area t)) + (slime-autodoc-stop-timer))) + +(defvar slime-autodoc-last-message "") + +(defun slime-autodoc () + "Print some apropos information about the code at point, if applicable." + (destructuring-bind (cache-key retrieve-form) (slime-autodoc-thing-at-point) + (let ((cached (slime-get-cached-autodoc cache-key))) + (if cached + (slime-autodoc-message cached) + ;; Asynchronously fetch, cache, and display documentation + (slime-eval-async + retrieve-form + (with-lexical-bindings (cache-key) + (lambda (doc) + (let ((doc (if doc (slime-fontify-string doc) ""))) + (slime-update-autodoc-cache cache-key doc) + (slime-autodoc-message doc))))))))) + +(defcustom slime-autodoc-use-multiline-p nil + "If non-nil, allow long autodoc messages to resize echo area display." + :type 'boolean + :group 'slime-ui) + +(defvar slime-autodoc-message-function 'slime-autodoc-show-message) + +(defun slime-autodoc-message (doc) + "Display the autodoc documentation string DOC." + (funcall slime-autodoc-message-function doc)) + +(defun slime-autodoc-show-message (doc) + (unless slime-autodoc-use-multiline-p + (setq doc (slime-oneliner doc))) + (setq slime-autodoc-last-message doc) + (message "%s" doc)) + +(defun slime-autodoc-message-dimensions () + "Return the available width and height for pretty printing autodoc +messages." + (cond + (slime-autodoc-use-multiline-p + ;; Use the full width of the minibuffer; + ;; minibuffer will grow vertically if necessary + (values (window-width (minibuffer-window)) + nil)) + (t + ;; Try to fit everything in one line; we cut off when displaying + (values 1000 1)))) + +(defun slime-autodoc-pre-command-refresh-echo-area () + (unless (string= slime-autodoc-last-message "") + (if (slime-autodoc-message-ok-p) + (message "%s" slime-autodoc-last-message) + (setq slime-autodoc-last-message "")))) + +(defun slime-autodoc-thing-at-point () + "Return a cache key and a swank form." + (let ((global (slime-autodoc-global-at-point))) + (if global + (values (slime-qualify-cl-symbol-name global) + `(swank:variable-desc-for-echo-area ,global)) + (multiple-value-bind (operators arg-indices points) + (slime-enclosing-form-specs) + (values (mapcar* (lambda (designator arg-index) + (cons + (if (symbolp designator) + (slime-qualify-cl-symbol-name designator) + designator) + arg-index)) + operators arg-indices) + (multiple-value-bind (width height) + (slime-autodoc-message-dimensions) + `(swank:arglist-for-echo-area ',operators + :arg-indices ',arg-indices + :print-right-margin ,width + :print-lines ,height))))))) + +(defun slime-autodoc-global-at-point () + "Return the global variable name at point, if any." + (when-let (name (slime-symbol-name-at-point)) + (if (slime-global-variable-name-p name) name))) + +(defcustom slime-global-variable-name-regexp "^\$.*:\$?\$[*+]\$.+\\2$" + "Regexp used to check if a symbol name is a global variable. + +Default value assumes +this+ or *that* naming conventions." + :type 'regexp + :group 'slime) + +(defun slime-global-variable-name-p (name) + "Is NAME a global variable? +Globals are recognised purely by *this-naming-convention*." + (and (< (length name) 80) ; avoid overflows in regexp matcher + (string-match slime-global-variable-name-regexp name))) + +(defun slime-get-cached-autodoc (symbol-name) + "Return the cached autodoc documentation for SYMBOL-NAME, or nil." + (ecase slime-autodoc-cache-type + ((nil) nil) + ((last) + (when (equal (car slime-autodoc-cache) symbol-name) + (cdr slime-autodoc-cache))) + ((all) + (when-let (symbol (intern-soft symbol-name)) + (get symbol 'slime-autodoc-cache))))) + +(defun slime-update-autodoc-cache (symbol-name documentation) + "Update the autodoc cache for SYMBOL with DOCUMENTATION. +Return DOCUMENTATION." + (ecase slime-autodoc-cache-type + ((nil) nil) + ((last) + (setq slime-autodoc-cache (cons symbol-name documentation))) + ((all) + (put (intern symbol-name) 'slime-autodoc-cache documentation))) + documentation) + + +;;;;; Asynchronous message idle timer + +(defvar slime-autodoc-idle-timer nil + "Idle timer for the next autodoc message.") + +(defvar slime-autodoc-delay 0.2 + "*Delay before autodoc messages are fetched and displayed, in seconds.") + +(defun slime-autodoc-start-timer () + "(Re)start the timer that prints autodocs every `slime-autodoc-delay' seconds." + (interactive) + (when slime-autodoc-idle-timer + (cancel-timer slime-autodoc-idle-timer)) + (setq slime-autodoc-idle-timer + (run-with-idle-timer slime-autodoc-delay slime-autodoc-delay + 'slime-autodoc-timer-hook))) + +(defun slime-autodoc-stop-timer () + "Stop the timer that prints autodocs. +See also `slime-autodoc-start-timer'." + (when slime-autodoc-idle-timer + (cancel-timer slime-autodoc-idle-timer) + (setq slime-autodoc-idle-timer nil))) + +(defun slime-autodoc-timer-hook () + "Function to be called after each Emacs becomes idle. +When `slime-autodoc-mode' is non-nil, print apropos information about +the symbol at point if applicable." + (when (slime-autodoc-message-ok-p) + (condition-case err + (slime-autodoc) + (error + (setq slime-autodoc-mode nil) + (message "Error: %S; slime-autodoc-mode now disabled." err))))) + +(defun slime-autodoc-message-ok-p () + "Return true if printing a message is currently okay (shouldn't +annoy the user)." + (and (or slime-mode (eq major-mode 'slime-repl-mode) + (eq major-mode 'sldb-mode)) + slime-autodoc-mode + (or (null (current-message)) + (string= (current-message) slime-autodoc-last-message)) + (not executing-kbd-macro) + (not (and (boundp 'edebug-active) (symbol-value 'edebug-active))) + (not cursor-in-echo-area) + (not (active-minibuffer-window)) + (not (eq (selected-window) (minibuffer-window))) + (slime-background-activities-enabled-p))) + + +;;; Initialization + +(defun slime-autodoc-init () + (setq slime-echo-arglist-function 'slime-autodoc) + (add-hook 'slime-connected-hook 'slime-autodoc-on-connect) + (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook)) + (add-hook h 'slime-autodoc-maybe-enable))) + +(defun slime-autodoc-on-connect () + (slime-eval-async '(swank:swank-require :swank-arglists))) + +(defun slime-autodoc-maybe-enable () + (when slime-use-autodoc-mode + (slime-autodoc-mode 1))) + +(defun slime-autodoc-unload () + (setq slime-echo-arglist-function 'slime-show-arglist) + (remove-hook 'slime-connected-hook 'slime-autodoc-on-connect) + (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook)) + (remove-hook h 'slime-autodoc-maybe-enable))) + +(provide 'slime-autodoc) Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-banner.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-banner.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-banner.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,44 @@ +;;; slime-banner.el -- Persistent header line and startup animation +;; +;; Authors: Helmut Eller <heller(a)common-lisp.net> +;; Luke Gorrie <luke(a)synap.se> +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path ".../slime/contrib") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-banner))) + +(defcustom slime-startup-animation (fboundp 'animate-string) + "Enable the startup animation." + :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) + :group 'slime-ui) + +(defcustom slime-header-line-p (boundp 'header-line-format) + "If non-nil, display a header line in Slime buffers." + :type 'boolean + :group 'slime-repl) + +(defun slime-startup-message () + (when slime-header-line-p + (setq header-line-format + (format "%s Port: %s Pid: %s" + (slime-lisp-implementation-type) + (slime-connection-port (slime-connection)) + (slime-pid)))) + (when (zerop (buffer-size)) + (let ((welcome (concat "; SLIME " (or (slime-changelog-date) + "- ChangeLog file not found")))) + (if slime-startup-animation + (animate-string welcome 0 0) + (insert welcome))))) + +(defun slime-banner-init () + (setq slime-repl-banner-function 'slime-startup-message)) + +(defun slime-banner-unload () + (setq slime-repl-banner-function 'slime-repl-insert-banner)) + +(provide 'slime-banner) Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,202 @@ +;;; slime-c-p-c.el --- ILISP style Compound Prefix Completion +;; +;; Authors: Luke Gorrie <luke(a)synap.se> +;; Edi Weitz <edi(a)agharta.de> +;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> +;; Tobias C. Rittweiler <tcr(a)freebits.de> +;; and others +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-c-p-c))) +;; + + + +(require 'slime) +(require 'slime-parse) +(require 'slime-editing-commands) + +(defcustom slime-c-p-c-unambiguous-prefix-p t + "If true, set point after the unambigous prefix. +If false, move point to the end of the inserted text." + :type 'boolean + :group 'slime-ui) + +(defcustom slime-complete-symbol*-fancy nil + "Use information from argument lists for DWIM'ish symbol completion." + :group 'slime-mode + :type 'boolean) + +(defun slime-complete-symbol* () + "Expand abbreviations and complete the symbol at point." + ;; NB: It is only the name part of the symbol that we actually want + ;; to complete -- the package prefix, if given, is just context. + (or (slime-maybe-complete-as-filename) + (slime-expand-abbreviations-and-complete))) + +;; FIXME: factorize +(defun slime-expand-abbreviations-and-complete () + (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) + (beg (move-marker (make-marker) (slime-symbol-start-pos))) + (prefix (buffer-substring-no-properties beg end)) + (completion-result (slime-contextual-completions beg end)) + (completion-set (first completion-result)) + (completed-prefix (second completion-result))) + (if (null completion-set) + (progn (slime-minibuffer-respecting-message + "Can't find completion for \"%s\"" prefix) + (ding) + (slime-complete-restore-window-configuration)) + ;; some XEmacs issue makes this distinction necessary + (cond ((> (length completed-prefix) (- end beg)) + (goto-char end) + (insert-and-inherit completed-prefix) + (delete-region beg end) + (goto-char (+ beg (length completed-prefix)))) + (t nil)) + (cond ((and (member completed-prefix completion-set) + (slime-length= completion-set 1)) + (slime-minibuffer-respecting-message "Sole completion") + (when slime-complete-symbol*-fancy + (slime-complete-symbol*-fancy-bit)) + (slime-complete-restore-window-configuration)) + ;; Incomplete + (t + (when (member completed-prefix completion-set) + (slime-minibuffer-respecting-message + "Complete but not unique")) + (when slime-c-p-c-unambiguous-prefix-p + (let ((unambiguous-completion-length + (loop for c in completion-set + minimizing (or (mismatch completed-prefix c) + (length completed-prefix))))) + (goto-char (+ beg unambiguous-completion-length)))) + (slime-display-or-scroll-completions completion-set + completed-prefix)))))) + +(defun slime-complete-symbol*-fancy-bit () + "Do fancy tricks after completing a symbol. +\(Insert a space or close-paren based on arglist information.)" + (let ((arglist (slime-get-arglist (slime-symbol-name-at-point)))) + (when arglist + (let ((args + ;; Don't intern these symbols + (let ((obarray (make-vector 10 0))) + (cdr (read arglist)))) + (function-call-position-p + (save-excursion + (backward-sexp) + (equal (char-before) ?\()))) + (when function-call-position-p + (if (null args) + (insert-and-inherit ")") + (insert-and-inherit " ") + (when (and slime-space-information-p + (slime-background-activities-enabled-p) + (not (minibuffer-window-active-p (minibuffer-window)))) + (slime-echo-arglist)))))))) + +(defun slime-get-arglist (symbol-name) + "Return the argument list for SYMBOL-NAME." + (slime-eval `(swank:arglist-for-echo-area (quote (,symbol-name))))) + +(defun* slime-contextual-completions (beg end) + "Return a list of completions of the token from BEG to END in the +current buffer." + (let ((token (buffer-substring-no-properties beg end))) + (cond + ((and (< beg (point-max)) + (string= (buffer-substring-no-properties beg (1+ beg)) ":")) + ;; Contextual keyword completion + (multiple-value-bind (operator-names arg-indices points) + (save-excursion + (goto-char beg) + (slime-enclosing-form-specs)) + (when operator-names + (let ((completions + (slime-completions-for-keyword operator-names token + arg-indices))) + (when (first completions) + (return-from slime-contextual-completions completions)) + ;; If no matching keyword was found, do regular symbol + ;; completion. + )))) + ((and (> beg 2) + (string= (buffer-substring-no-properties (- beg 2) beg) "#\\")) + ;; Character name completion + (return-from slime-contextual-completions + (slime-completions-for-character token)))) + ;; Regular symbol completion + (slime-completions token))) + +(defun slime-completions (prefix) + (slime-eval `(swank:completions ,prefix ',(slime-current-package)))) + +(defun slime-completions-for-keyword (operator-designator prefix + arg-indices) + (slime-eval `(swank:completions-for-keyword ',operator-designator + ,prefix + ',arg-indices))) + +(defun slime-completions-for-character (prefix) + (slime-eval `(swank:completions-for-character ,prefix))) + + +;;; Complete form + +(defun slime-complete-form () + "Complete the form at point. +This is a superset of the functionality of `slime-insert-arglist'." + (interactive) + ;; Find the (possibly incomplete) form around point. + (let ((form-string (slime-incomplete-form-at-point))) + (let ((result (slime-eval `(swank:complete-form ',form-string)))) + (if (eq result :not-available) + (error "Could not generate completion for the form `%s'" form-string) + (progn + (just-one-space) + (save-excursion + ;; SWANK:COMPLETE-FORM always returns a closing + ;; parenthesis; but we only want to insert one if it's + ;; really necessary (thinking especially of paredit.el.) + (insert (substring result 0 -1)) + (let ((slime-close-parens-limit 1)) + (slime-close-all-parens-in-sexp))) + (save-excursion + (backward-up-list 1) + (indent-sexp))))))) + +;;; Initialization + +(defvar slime-c-p-c-init-undo-stack nil) + +(defun slime-c-p-c-init () + ;; save current state for unload + (push + `(progn + (setq slime-complete-symbol-function ',slime-complete-symbol-function) + (remove-hook 'slime-connected-hook 'slime-c-p-c-on-connect) + (define-key slime-mode-map "\C-c\C-s" + ',(lookup-key slime-mode-map "\C-c\C-s")) + (define-key slime-repl-mode-map "\C-c\C-s" + ',(lookup-key slime-repl-mode-map "\C-c\C-s"))) + slime-c-p-c-init-undo-stack) + (setq slime-complete-symbol-function 'slime-complete-symbol*) + (add-hook 'slime-connected-hook 'slime-c-p-c-on-connect) + (define-key slime-mode-map "\C-c\C-s" 'slime-complete-form) + (define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form)) + +(defun slime-c-p-c-on-connect () + (slime-eval-async '(swank:swank-require :swank-arglists))) + +(defun slime-c-p-c-unload () + (while slime-c-p-c-init-undo-stack + (eval (pop slime-c-p-c-init-undo-stack)))) + +(provide 'slime-c-p-c) Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,189 @@ +;;; slime-editing-commands.el -- editing commands whithout server interaction +;; +;; Authors: Thomas F. Burdick <tfb(a)OCF.Berkeley.EDU> +;; Luke Gorrie <luke(a)synap.se> +;; Bill Clementson <billclem(a)gmail.com> +;; Tobias C. Rittweiler <tcr(a)freebits.de> +;; and others +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-editing-commands))) +;; + +(defun slime-beginning-of-defun () + (interactive) + (if (and (boundp 'slime-repl-input-start-mark) + slime-repl-input-start-mark) + (slime-repl-beginning-of-defun) + (beginning-of-defun))) + +(defun slime-end-of-defun () + (interactive) + (if (and (boundp 'slime-repl-input-end-mark) + slime-repl-input-end-mark) + (slime-repl-end-of-defun) + (end-of-defun))) + +(defvar slime-comment-start-regexp + "\$\\(^\\|[^\n\\\\]\$\$[\\\\][\\\\]\$*\\);+[ \t]*" + "Regexp to match the start of a comment.") + +(defun slime-beginning-of-comment () + "Move point to beginning of comment. +If point is inside a comment move to beginning of comment and return point. +Otherwise leave point unchanged and return NIL." + (let ((boundary (point))) + (beginning-of-line) + (cond ((re-search-forward slime-comment-start-regexp boundary t) + (point)) + (t (goto-char boundary) + nil)))) + +(defun slime-close-all-parens-in-sexp (&optional region) + "Balance parentheses of open s-expressions at point. +Insert enough right parentheses to balance unmatched left parentheses. +Delete extra left parentheses. Reformat trailing parentheses +Lisp-stylishly. + +If REGION is true, operate on the region. Otherwise operate on +the top-level sexp before point." + (interactive "P") + (let ((sexp-level 0) + point) + (save-excursion + (save-restriction + (when region + (narrow-to-region (region-beginning) (region-end)) + (goto-char (point-max))) + ;; skip over closing parens, but not into comment + (skip-chars-backward ") \t\n") + (when (slime-beginning-of-comment) + (forward-line) + (skip-chars-forward " \t")) + (setq point (point)) + ;; count sexps until either '(' or comment is found at first column + (while (and (not (looking-at "^[(;]")) + (ignore-errors (backward-up-list 1) t)) + (incf sexp-level)))) + (when (> sexp-level 0) + ;; insert correct number of right parens + (goto-char point) + (dotimes (i sexp-level) (insert ")")) + ;; delete extra right parens + (setq point (point)) + (skip-chars-forward " \t\n)") + (skip-chars-backward " \t\n") + (let* ((deleted-region (delete-and-extract-region point (point))) + (deleted-text (substring-no-properties deleted-region)) + (prior-parens-count (count ?\) deleted-text))) + ;; Remember: we always insert as many parentheses as necessary + ;; and only afterwards delete the superfluously-added parens. + (when slime-close-parens-limit + (let ((missing-parens (- sexp-level prior-parens-count + slime-close-parens-limit))) + (dotimes (i (max 0 missing-parens)) + (delete-char -1)))))))) + +(defvar slime-close-parens-limit nil + "Maxmimum parens for `slime-close-all-sexp' to insert. NIL +means to insert as many parentheses as necessary to correctly +close the form.") + +(defun slime-insert-balanced-comments (arg) + "Insert a set of balanced comments around the s-expression +containing the point. If this command is invoked repeatedly +\(without any other command occurring between invocations), the +comment progressively moves outward over enclosing expressions. +If invoked with a positive prefix argument, the s-expression arg +expressions out is enclosed in a set of balanced comments." + (interactive "*p") + (save-excursion + (when (eq last-command this-command) + (when (search-backward "#|" nil t) + (save-excursion + (delete-char 2) + (while (and (< (point) (point-max)) (not (looking-at " *|#"))) + (forward-sexp)) + (replace-match "")))) + (while (> arg 0) + (backward-char 1) + (cond ((looking-at ")") (incf arg)) + ((looking-at "(") (decf arg)))) + (insert "#|") + (forward-sexp) + (insert "|#"))) + +(defun slime-remove-balanced-comments () + "Remove a set of balanced comments enclosing point." + (interactive "*") + (save-excursion + (when (search-backward "#|" nil t) + (delete-char 2) + (while (and (< (point) (point-max)) (not (looking-at " *|#"))) + (forward-sexp)) + (replace-match "")))) + + +;; SLIME-CLOSE-PARENS-AT-POINT is obsolete: + +;; It doesn't work correctly on the REPL, because there +;; BEGINNING-OF-DEFUN-FUNCTION and END-OF-DEFUN-FUNCTION is bound to +;; SLIME-REPL-MODE-BEGINNING-OF-DEFUN (and +;; SLIME-REPL-MODE-END-OF-DEFUN respectively) which compromises the +;; way how they're expect to work (i.e. END-OF-DEFUN does not signal +;; an UNBOUND-PARENTHESES error.) + +;; Use SLIME-CLOSE-ALL-PARENS-IN-SEXP instead. + +;; (defun slime-close-parens-at-point () +;; "Close parenthesis at point to complete the top-level-form. Simply +;; inserts ')' characters at point until `beginning-of-defun' and +;; `end-of-defun' execute without errors, or `slime-close-parens-limit' +;; is exceeded." +;; (interactive) +;; (loop for i from 1 to slime-close-parens-limit +;; until (save-excursion +;; (slime-beginning-of-defun) +;; (ignore-errors (slime-end-of-defun) t)) +;; do (insert ")"))) + +(defun slime-reindent-defun (&optional force-text-fill) + "Reindent the current defun, or refill the current paragraph. +If point is inside a comment block, the text around point will be +treated as a paragraph and will be filled with `fill-paragraph'. +Otherwise, it will be treated as Lisp code, and the current defun +will be reindented. If the current defun has unbalanced parens, +an attempt will be made to fix it before reindenting. + +When given a prefix argument, the text around point will always +be treated as a paragraph. This is useful for filling docstrings." + (interactive "P") + (save-excursion + (if (or force-text-fill (slime-beginning-of-comment)) + (fill-paragraph nil) + (let ((start (progn (unless (or (and (zerop (current-column)) + (eq ?\( (char-after))) + (and slime-repl-input-start-mark + (slime-repl-at-prompt-start-p))) + (slime-beginning-of-defun)) + (point))) + (end (ignore-errors (slime-end-of-defun) (point)))) + (unless end + (forward-paragraph) + (slime-close-all-parens-in-sexp) + (slime-end-of-defun) + (setf end (point))) + (indent-region start end nil))))) + +(defun slime-editing-commands-init () + (define-key slime-mode-map "\M-\C-a" 'slime-beginning-of-defun) + (define-key slime-mode-map "\M-\C-e" 'slime-end-of-defun) + (define-key slime-mode-map "\C-c\M-q" 'slime-reindent-defun)) + +(provide 'slime-editing-commands) Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,28 @@ +;;; slime-fancy-inspector.el --- Fancy inspector for CLOS objects +;; +;; Author: Marco Baringer <mb(a)bese.it> and others +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-fancy-inspector))) +;; (add-hook 'slime-connected-hook 'slime-install-fancy-inspector) + +(defun slime-install-fancy-inspector () + (slime-eval-async '(swank:swank-require :swank-fancy-inspector) + (lambda (_) + (slime-eval-async '(swank:fancy-inspector-init))))) + +(defun slime-deinstall-fancy-inspector () + (slime-eval-async '(swank:fancy-inspector-unload))) + +(defun slime-fancy-inspector-init () + (add-hook 'slime-connected-hook 'slime-install-fancy-inspector)) + +(defun slime-fancy-inspector-unload () + (remove-hook 'slime-connected-hook 'slime-install-fancy-inspector)) + +(provide 'slime-fancy-inspector) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,74 @@ +;;; slime-fancy.el --- Load and init some fancy SLIME contribs +;; +;; Authors: Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-fancy))) +;; +;; We load all SLIME contribs that are currently working, +;; and which only "upgrade" the behavior of SLIME in some way. +;; This includes: +;; * Adding new commands, keybindings, menu items +;; * Making things clickable that would otherwise be just plain text + +;; Better arglist display, can be turned off by customization. +(require 'slime-autodoc) +(slime-autodoc-init) + +;; Adds new commands and installs compound-prefix-completion as +;; default completion command. Behaves similar to standard Emacs +;; completion, unless dashes are present. --mkoeppe +(require 'slime-c-p-c) +(slime-c-p-c-init) + +;; Just adds commands. (Well, shadows commands in lisp-mode-map) +(require 'slime-editing-commands) +(slime-editing-commands-init) + +;; Makes the inspector fancier. +(require 'slime-fancy-inspector) +(slime-fancy-inspector-init) + +;; Just adds the command C-c M-i. We do not make fuzzy completion the +;; default completion invoked by TAB. --mkoeppe +(require 'slime-fuzzy) +(slime-fuzzy-init) + +;; Do not activate slime-highlighting-edits by default, as it's easier +;; to explictly activate it (if a user really wants it) than to explictly +;; deactivate it once it got globally enabled. -TCR. +(require 'slime-highlight-edits) +;(slime-highlight-edits-init) + +;; Load slime-presentations even though they seem to be a +;; controversial feature, as they can be easily turned off by +;; customizing swank:*record-repl-results*. --mkoeppe +(require 'slime-presentations) +(slime-presentations-init) + +;;; Do not load slime-presentation-streams, as this is an experimental +;;; feature that installs patches into some Lisps. --mkoeppe +;;(require 'slime-presentation-streams) + +(require 'slime-scratch) +(slime-scratch-init) + +;;; Do not load slime-typeout-frame, as simply loading causes display of a +;;; typeout frame, which cannot be turned off. --mkoeppe +;;(require 'slime-typeout-frame) + +;; Just adds commands. +(when (locate-library "tree-widget") + (require 'slime-xref-browser)) + +;; Puts clickable references to documentation into SBCL errors. +(require 'slime-references) +(slime-references-init) + +(provide 'slime-fancy) Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,598 @@ +;;; slime-fuzzy.el --- fuzzy symbol completion +;; +;; Authors: Brian Downing <bdowning(a)lavos.net> +;; Tobias C. Rittweiler <tcr(a)freebits.de> +;; Attila Lendvai <attila.lendvai(a)gmail.com> +;; and others +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-fuzzy))) +;; + + +;;; Code + +(defcustom slime-fuzzy-completion-in-place t + "When non-NIL the fuzzy symbol completion is done in place as +opposed to moving the point to the completion buffer." + :group 'slime-mode + :type 'boolean) + +(defcustom slime-fuzzy-completion-limit 300 + "Only return and present this many symbols from swank." + :group 'slime-mode + :type 'integer) + +(defcustom slime-fuzzy-completion-time-limit-in-msec 1500 + "Limit the time spent (given in msec) in swank while gathering comletitions. +\(NOTE: currently it's rounded up the nearest second)" + :group 'slime-mode + :type 'integer) + +(defvar slime-fuzzy-target-buffer nil + "The buffer that is the target of the completion activities.") +(defvar slime-fuzzy-saved-window-configuration nil + "The saved window configuration before the fuzzy completion +buffer popped up.") +(defvar slime-fuzzy-start nil + "The beginning of the completion slot in the target buffer. +This is a non-advancing marker.") +(defvar slime-fuzzy-end nil + "The end of the completion slot in the target buffer. +This is an advancing marker.") +(defvar slime-fuzzy-original-text nil + "The original text that was in the completion slot in the +target buffer. This is what is put back if completion is +aborted.") +(defvar slime-fuzzy-text nil + "The text that is currently in the completion slot in the +target buffer. If this ever doesn't match, the target buffer has +been modified and we abort without touching it.") +(defvar slime-fuzzy-first nil + "The position of the first completion in the completions buffer. +The descriptive text and headers are above this.") +(defvar slime-fuzzy-last nil + "The position of the last completion in the completions buffer. +If the time limit has exhausted during generation possible completion +choices inside SWANK, an indication is printed below this.") +(defvar slime-fuzzy-current-completion nil + "The current completion object. If this is the same before and +after point moves in the completions buffer, the text is not +replaced in the target for efficiency.") +(defvar slime-fuzzy-current-completion-overlay nil + "The overlay representing the current completion in the completion +buffer. This is used to hightlight the text.") + +;;;;;;; slime-target-buffer-fuzzy-completions-mode +;; NOTE: this mode has to be able to override key mappings in slime-mode + +;; FIXME: clean this up + +(defun mimic-key-bindings (from-keymap to-keymap bindings-or-operation operation) + "Iterate on BINDINGS-OR-OPERATION. If an element is a symbol then +try to look it up (as an operation) in FROM-KEYMAP. Non symbols are taken +as default key bindings when none to be mimiced was found in FROM-KEYMAP. +Set the resulting list of keys in TO-KEYMAP to OPERATION." + (let ((mimic-keys nil) + (direct-keys nil)) + (dolist (key-or-operation bindings-or-operation) + (if (symbolp key-or-operation) + (setf mimic-keys (append mimic-keys (where-is-internal key-or-operation from-keymap nil t))) + (push key-or-operation direct-keys))) + (dolist (key (or mimic-keys direct-keys)) + (define-key to-keymap key operation)))) + +(defvar slime-target-buffer-fuzzy-completions-map + (let* ((map (make-sparse-keymap))) + (flet ((remap (keys to) + (mimic-key-bindings global-map map keys to))) + + (remap (list 'keyboard-quit (kbd "C-g")) 'slime-fuzzy-abort) + + (remap (list 'slime-fuzzy-indent-and-complete-symbol + 'slime-indent-and-complete-symbol + (kbd "<tab>")) + 'slime-fuzzy-select-or-update-completions) + (remap (list 'previous-line (kbd "<up>")) 'slime-fuzzy-prev) + (remap (list 'next-line (kbd "<down>")) 'slime-fuzzy-next) + (remap (list 'isearch-forward (kbd "C-s")) + (lambda () + (interactive) + (select-window (get-buffer-window (slime-get-fuzzy-buffer))) + (call-interactively 'isearch-forward))) + + ;; some unconditional direct bindings + (dolist (key (list (kbd "<return>") (kbd "RET") (kbd "<SPC>") "(" ")" "[" "]")) + (define-key map key 'slime-fuzzy-select-and-process-event-in-target-buffer))) + map + ) + "Keymap for slime-target-buffer-fuzzy-completions-mode. This will override the key +bindings in the target buffer temporarily during completion.") + +;; Make sure slime-fuzzy-target-buffer-completions-mode's map is +;; before everything else. +(setf minor-mode-map-alist + (stable-sort minor-mode-map-alist + (lambda (a b) + (eq a 'slime-fuzzy-target-buffer-completions-mode)) + :key #'car)) + + +(define-minor-mode slime-fuzzy-target-buffer-completions-mode + "This minor mode is intented to override key bindings during fuzzy +completions in the target buffer. Most of the bindings will do an implicit select +in the completion window and let the keypress be processed in the target buffer." + nil + nil + slime-target-buffer-fuzzy-completions-map) + +(add-to-list 'minor-mode-alist + '(slime-fuzzy-target-buffer-completions-mode + " Fuzzy Target Buffer Completions")) + +(define-derived-mode slime-fuzzy-completions-mode + fundamental-mode "Fuzzy Completions" + "Major mode for presenting fuzzy completion results. + +When you run `slime-fuzzy-complete-symbol', the symbol token at +point is completed using the Fuzzy Completion algorithm; this +means that the token is taken as a sequence of characters and all +the various possibilities that this sequence could meaningfully +represent are offered as selectable choices, sorted by how well +they deem to be a match for the token. (For instance, the first +choice of completing on \"mvb\" would be \"multiple-value-bind\".) + +Therefore, a new buffer (*Fuzzy Completions*) will pop up that +contains the different completion choices. Simultaneously, a +special minor-mode will be temporarily enabled in the original +buffer where you initiated fuzzy completion (also called the +``target buffer'') in order to navigate through the *Fuzzy +Completions* buffer without leaving. + +With focus in *Fuzzy Completions*: + Type `n' and `p' (`UP', `DOWN') to navigate between completions. + Type `RET' or `TAB' to select the completion near point. + Type `q' to abort. + +With focus in the target buffer: + Type `UP' and `DOWN' to navigate between completions. + Type a character that does not constitute a symbol name + to insert the current choice and then that character (`(', `)', + `SPACE', `RET'.) Use `TAB' to simply insert the current choice. + Use C-g to abort. + +Alternatively, you can click <mouse-2> on a completion to select it. + + +Complete listing of keybindings within the target buffer: + +\\<slime-target-buffer-fuzzy-completions-map>\ +\\{slime-target-buffer-fuzzy-completions-map} + +Complete listing of keybindings with *Fuzzy Completions*: + +\\<slime-fuzzy-completions-map>\ +\\{slime-fuzzy-completions-map}" + (use-local-map slime-fuzzy-completions-map)) + +(defvar slime-fuzzy-completions-map + (let* ((map (make-sparse-keymap))) + (flet ((remap (keys to) + (mimic-key-bindings global-map map keys to))) + (remap (list 'keyboard-quit (kbd "C-g")) 'slime-fuzzy-abort) + (define-key map "q" 'slime-fuzzy-abort) + + (remap (list 'previous-line (kbd "<up>")) 'slime-fuzzy-prev) + (remap (list 'next-line (kbd "<down>")) 'slime-fuzzy-next) + + (define-key map "n" 'slime-fuzzy-next) + (define-key map "\M-n" 'slime-fuzzy-next) + + (define-key map "p" 'slime-fuzzy-prev) + (define-key map "\M-p" 'slime-fuzzy-prev) + + (define-key map "\d" 'scroll-down) + + (remap (list 'slime-fuzzy-indent-and-complete-symbol + 'slime-indent-and-complete-symbol + (kbd "<tab>")) + 'slime-fuzzy-select) + + (define-key map (kbd "<mouse-2>") 'slime-fuzzy-select/mouse)) + + (define-key map (kbd "RET") 'slime-fuzzy-select) + (define-key map (kbd "<SPC>") 'slime-fuzzy-select) + + map) + "Keymap for slime-fuzzy-completions-mode when in the completion buffer.") + +(defun slime-fuzzy-completions (prefix &optional default-package) + "Get the list of sorted completion objects from completing +`prefix' in `package' from the connected Lisp." + (let ((prefix (etypecase prefix + (symbol (symbol-name prefix)) + (string prefix)))) + (slime-eval `(swank:fuzzy-completions ,prefix + ,(or default-package + (slime-find-buffer-package) + (slime-current-package)) + :limit ,slime-fuzzy-completion-limit + :time-limit-in-msec ,slime-fuzzy-completion-time-limit-in-msec)))) + +(defun slime-fuzzy-selected (prefix completion) + "Tell the connected Lisp that the user selected completion +`completion' as the completion for `prefix'." + (let ((no-properties (copy-sequence prefix))) + (set-text-properties 0 (length no-properties) nil no-properties) + (slime-eval `(swank:fuzzy-completion-selected ,no-properties + ',completion)))) + +(defun slime-fuzzy-indent-and-complete-symbol () + "Indent the current line and perform fuzzy symbol completion. First +indent the line. If indenting doesn't move point, complete the +symbol. If there's no symbol at the point, show the arglist for the +most recently enclosed macro or function." + (interactive) + (let ((pos (point))) + (unless (get-text-property (line-beginning-position) 'slime-repl-prompt) + (lisp-indent-line)) + (when (= pos (point)) + (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t)) + (slime-fuzzy-complete-symbol)) + ((memq (char-before) '(?\t ?\ )) + (slime-echo-arglist)))))) + +(defun* slime-fuzzy-complete-symbol () + "Fuzzily completes the abbreviation at point into a symbol." + (interactive) + (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) + (return-from slime-fuzzy-complete-symbol + (if slime-when-complete-filename-expand + (comint-replace-by-expanded-filename) + (comint-dynamic-complete-as-filename)))) + (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) + (beg (move-marker (make-marker) (slime-symbol-start-pos))) + (prefix (buffer-substring-no-properties beg end))) + (destructuring-bind (completion-set interrupted-p) + (slime-fuzzy-completions prefix) + (if (null completion-set) + (progn (slime-minibuffer-respecting-message + "Can't find completion for \"%s\"" prefix) + (ding) + (slime-fuzzy-done)) + (goto-char end) + (cond ((slime-length= completion-set 1) + (insert-and-inherit (caar completion-set)) ; insert completed string + (delete-region beg end) + (goto-char (+ beg (length (caar completion-set)))) + (slime-minibuffer-respecting-message "Sole completion") + (slime-fuzzy-done)) + ;; Incomplete + (t + (slime-minibuffer-respecting-message "Complete but not unique") + (slime-fuzzy-choices-buffer completion-set interrupted-p beg end))))))) + + +(defun slime-get-fuzzy-buffer () + (get-buffer-create "*Fuzzy Completions*")) + +(defvar slime-fuzzy-explanation + "For help on how the use this buffer, see `slime-fuzzy-completions-mode'. + +Flags: boundp fboundp generic-function class macro special-operator package +\n" + "The explanation that gets inserted at the beginning of the +*Fuzzy Completions* buffer.") + +(defun slime-fuzzy-insert-completion-choice (completion max-length) + "Inserts the completion object `completion' as a formatted +completion choice into the current buffer, and mark it with the +proper text properties." + (let ((start (point)) + (symbol-name (first completion)) + (score (second completion)) + (chunks (third completion)) + (flags (fourth completion))) + (insert symbol-name) + (let ((end (point))) + (dolist (chunk chunks) + (put-text-property (+ start (first chunk)) + (+ start (first chunk) + (length (second chunk))) + 'face 'bold)) + (put-text-property start (point) 'mouse-face 'highlight) + (dotimes (i (- max-length (- end start))) + (insert " ")) + (insert (format " %s%s%s%s%s%s%s %8.2f" + (if (member :boundp flags) "b" "-") + (if (member :fboundp flags) "f" "-") + (if (member :generic-function flags) "g" "-") + (if (member :class flags) "c" "-") + (if (member :macro flags) "m" "-") + (if (member :special-operator flags) "s" "-") + (if (member :package flags) "p" "-") + score)) + (insert "\n") + (put-text-property start (point) 'completion completion)))) + +(defun slime-fuzzy-insert (text) + "Inserts `text' into the target buffer in the completion slot. +If the buffer has been modified in the meantime, abort the +completion process. Otherwise, update all completion variables +so that the new text is present." + (with-current-buffer slime-fuzzy-target-buffer + (cond + ((not (string-equal slime-fuzzy-text + (buffer-substring slime-fuzzy-start + slime-fuzzy-end))) + (slime-fuzzy-done) + (beep) + (message "Target buffer has been modified!")) + (t + (goto-char slime-fuzzy-start) + (delete-region slime-fuzzy-start slime-fuzzy-end) + (insert-and-inherit text) + (setq slime-fuzzy-text text) + (goto-char slime-fuzzy-end))))) + +(defun slime-fuzzy-choices-buffer (completions interrupted-p start end) + "Creates (if neccessary), populates, and pops up the *Fuzzy +Completions* buffer with the completions from `completions' and +the completion slot in the current buffer bounded by `start' and +`end'. This saves the window configuration before popping the +buffer so that it can possibly be restored when the user is +done." + (let ((new-completion-buffer (not slime-fuzzy-target-buffer))) + (when new-completion-buffer + (setq slime-fuzzy-saved-window-configuration + (current-window-configuration))) + (slime-fuzzy-enable-target-buffer-completions-mode) + (setq slime-fuzzy-target-buffer (current-buffer)) + (setq slime-fuzzy-start (move-marker (make-marker) start)) + (setq slime-fuzzy-end (move-marker (make-marker) end)) + (set-marker-insertion-type slime-fuzzy-end t) + (setq slime-fuzzy-original-text (buffer-substring start end)) + (setq slime-fuzzy-text slime-fuzzy-original-text) + (slime-fuzzy-fill-completions-buffer completions interrupted-p) + (pop-to-buffer (slime-get-fuzzy-buffer)) + (when new-completion-buffer + ;; Hook to nullify window-config restoration if the user changes + ;; the window configuration himself. + (when (boundp 'window-configuration-change-hook) + (add-hook 'window-configuration-change-hook + 'slime-fuzzy-window-configuration-change)) + (add-local-hook 'kill-buffer-hook 'slime-fuzzy-abort) + (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc + (when slime-fuzzy-completion-in-place + ;; switch back to the original buffer + (switch-to-buffer-other-window slime-fuzzy-target-buffer)))) + +(defun slime-fuzzy-fill-completions-buffer (completions interrupted-p) + "Erases and fills the completion buffer with the given completions." + (with-current-buffer (slime-get-fuzzy-buffer) + (setq buffer-read-only nil) + (erase-buffer) + (slime-fuzzy-completions-mode) + (insert slime-fuzzy-explanation) + (let ((max-length 12)) + (dolist (completion completions) + (setf max-length (max max-length (length (first completion))))) + + (insert "Completion:") + (dotimes (i (- max-length 10)) (insert " ")) + ;; Flags: Score: + ;; ... ------- -------- + ;; bfgcmsp + (insert "Flags: Score:\n") + (dotimes (i max-length) (insert "-")) + (insert " ------- --------\n") + (setq slime-fuzzy-first (point)) + + (dolist (completion completions) + (setq slime-fuzzy-last (point)) ; will eventually become the last entry + (slime-fuzzy-insert-completion-choice completion max-length)) + + (when interrupted-p + (insert "...\n") + (insert "[Interrupted: time limit exhausted]")) + + (setq buffer-read-only t)) + (setq slime-fuzzy-current-completion + (caar completions)) + (goto-char 0) + (slime-fuzzy-next))) + +(defun slime-fuzzy-enable-target-buffer-completions-mode () + "Store the target buffer's local map, so that we can restore it." + (unless slime-fuzzy-target-buffer-completions-mode +; (slime-log-event "Enabling target buffer completions mode") + (slime-fuzzy-target-buffer-completions-mode 1))) + +(defun slime-fuzzy-disable-target-buffer-completions-mode () + "Restores the target buffer's local map when completion is finished." + (when slime-fuzzy-target-buffer-completions-mode +; (slime-log-event "Disabling target buffer completions mode") + (slime-fuzzy-target-buffer-completions-mode 0))) + +(defun slime-fuzzy-insert-from-point () + "Inserts the completion that is under point in the completions +buffer into the target buffer. If the completion in question had +already been inserted, it does nothing." + (with-current-buffer (slime-get-fuzzy-buffer) + (let ((current-completion (get-text-property (point) 'completion))) + (when (and current-completion + (not (eq slime-fuzzy-current-completion + current-completion))) + (slime-fuzzy-insert + (first (get-text-property (point) 'completion))) + (setq slime-fuzzy-current-completion + current-completion))))) + +(defun slime-fuzzy-post-command-hook () + "The post-command-hook for the *Fuzzy Completions* buffer. +This makes sure the completion slot in the target buffer matches +the completion that point is on in the completions buffer." + (condition-case err + (when slime-fuzzy-target-buffer + (slime-fuzzy-insert-from-point)) + (error + ;; Because this is called on the post-command-hook, we mustn't let + ;; errors propagate. + (message "Error in slime-fuzzy-post-command-hook: %S" err)))) + +(defun slime-fuzzy-next () + "Moves point directly to the next completion in the completions +buffer." + (interactive) + (with-current-buffer (slime-get-fuzzy-buffer) + (slime-fuzzy-dehighlight-current-completion) + (let ((point (next-single-char-property-change (point) 'completion nil slime-fuzzy-last))) + (set-window-point (get-buffer-window (current-buffer)) point) + (goto-char point)) + (slime-fuzzy-highlight-current-completion))) + +(defun slime-fuzzy-prev () + "Moves point directly to the previous completion in the +completions buffer." + (interactive) + (with-current-buffer (slime-get-fuzzy-buffer) + (slime-fuzzy-dehighlight-current-completion) + (let ((point (previous-single-char-property-change (point) 'completion nil slime-fuzzy-first))) + (set-window-point (get-buffer-window (current-buffer)) point) + (goto-char point)) + (slime-fuzzy-highlight-current-completion))) + +(defun slime-fuzzy-dehighlight-current-completion () + "Restores the original face for the current completion." + (when slime-fuzzy-current-completion-overlay + (overlay-put slime-fuzzy-current-completion-overlay 'face 'nil))) + +(defun slime-fuzzy-highlight-current-completion () + "Highlights the current completion, so that the user can see it on the screen." + (let ((pos (point))) + (setq slime-fuzzy-current-completion-overlay + (make-overlay (point) (1- (search-forward " ")) + (current-buffer) t nil)) + (overlay-put slime-fuzzy-current-completion-overlay 'face 'secondary-selection) + (goto-char pos))) + +(defun slime-fuzzy-abort () + "Aborts the completion process, setting the completions slot in +the target buffer back to its original contents." + (interactive) + (when slime-fuzzy-target-buffer + (slime-fuzzy-done))) + +(defun slime-fuzzy-select () + "Selects the current completion, making sure that it is inserted +into the target buffer. This tells the connected Lisp what completion +was selected." + (interactive) + (when slime-fuzzy-target-buffer + (with-current-buffer (slime-get-fuzzy-buffer) + (let ((completion (get-text-property (point) 'completion))) + (when completion + (slime-fuzzy-insert (first completion)) + (slime-fuzzy-selected slime-fuzzy-original-text + completion) + (slime-fuzzy-done)))))) + +(defun slime-fuzzy-select-or-update-completions () + "If there were no changes since the last time fuzzy completion was started +this function will select the current completion. Otherwise refreshes the completion +list based on the changes made." + (interactive) +; (slime-log-event "Selecting or updating completions") + (if (string-equal slime-fuzzy-original-text + (buffer-substring slime-fuzzy-start + slime-fuzzy-end)) + (slime-fuzzy-select) + (slime-fuzzy-complete-symbol))) + +(defun slime-fuzzy-process-event-in-completions-buffer () + "Simply processes the event in the target buffer" + (interactive) + (with-current-buffer (slime-get-fuzzy-buffer) + (push last-input-event unread-command-events))) + +(defun slime-fuzzy-select-and-process-event-in-target-buffer () + "Selects the current completion, making sure that it is inserted +into the target buffer and processes the event in the target buffer." + (interactive) +; (slime-log-event "Selecting and processing event in target buffer") + (when slime-fuzzy-target-buffer + (let ((buff slime-fuzzy-target-buffer)) + (slime-fuzzy-select) + (with-current-buffer buff + (slime-fuzzy-disable-target-buffer-completions-mode) + (push last-input-event unread-command-events))))) + +(defun slime-fuzzy-select/mouse (event) + "Handle a mouse-2 click on a completion choice as if point were +on the completion choice and the slime-fuzzy-select command was +run." + (interactive "e") + (with-current-buffer (window-buffer (posn-window (event-end event))) + (save-excursion + (goto-char (posn-point (event-end event))) + (when (get-text-property (point) 'mouse-face) + (slime-fuzzy-insert-from-point) + (slime-fuzzy-select))))) + +(defun slime-fuzzy-done () + "Cleans up after the completion process. This removes all hooks, +and attempts to restore the window configuration. If this fails, +it just burys the completions buffer and leaves the window +configuration alone." + (when slime-fuzzy-target-buffer + (set-buffer slime-fuzzy-target-buffer) + (slime-fuzzy-disable-target-buffer-completions-mode) + (if (slime-fuzzy-maybe-restore-window-configuration) + (bury-buffer (slime-get-fuzzy-buffer)) + ;; We couldn't restore the windows, so just bury the fuzzy + ;; completions buffer and let something else fill it in. + (pop-to-buffer (slime-get-fuzzy-buffer)) + (bury-buffer)) + (pop-to-buffer slime-fuzzy-target-buffer) + (goto-char slime-fuzzy-end) + (setq slime-fuzzy-target-buffer nil) + (remove-hook 'window-configuration-change-hook + 'slime-fuzzy-window-configuration-change))) + +(defun slime-fuzzy-maybe-restore-window-configuration () + "Restores the saved window configuration if it has not been +nullified." + (when (boundp 'window-configuration-change-hook) + (remove-hook 'window-configuration-change-hook + 'slime-fuzzy-window-configuration-change)) + (if (not slime-fuzzy-saved-window-configuration) + nil + (set-window-configuration slime-fuzzy-saved-window-configuration) + (setq slime-fuzzy-saved-window-configuration nil) + t)) + +(defun slime-fuzzy-window-configuration-change () + "Called on window-configuration-change-hook. Since the window +configuration was changed, we nullify our saved configuration." + (setq slime-fuzzy-saved-window-configuration nil)) + +;;; Initialization + +(defun slime-fuzzy-init () + (add-hook 'slime-connected-hook 'slime-fuzzy-on-connect) + (slime-fuzzy-bind-keys)) + +(defun slime-fuzzy-bind-keys () + (define-key slime-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol) + (define-key slime-repl-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol)) + +(defun slime-fuzzy-on-connect () + (slime-eval-async '(swank:swank-require :swank-fuzzy))) + +(provide 'slime-fuzzy) Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-highlight-edits.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-highlight-edits.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-highlight-edits.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,99 @@ +;;; slime-higlight-edits --- highlight edited, i.e. not yet compiled, code +;; +;; Author: William Bland <doctorbill.news(a)gmail.com> and others +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this your .emacs: +;; +;; (add-to-list 'load-path "<contrib-dir>") +;; (autoload 'slime-highlight-edits-mode "slime-highlight-edits") +;; (add-hook 'slime-mode-hook (lambda () (slime-highlight-edits-mode 1))) + +(defface slime-highlight-edits-face + `((((class color) (background light)) + (:background "lightgray")) + (((class color) (background dark)) + (:background "dimgray")) + (t (:background "yellow"))) + "Face for displaying edit but not compiled code." + :group 'slime-mode-faces) + +(define-minor-mode slime-highlight-edits-mode + "Minor mode to highlight not-yet-compiled code." nil) + +(add-hook 'slime-highlight-edits-mode-on-hook + 'slime-highlight-edits-init-buffer) + +(add-hook 'slime-highlight-edits-mode-off-hook + 'slime-highlight-edits-reset-buffer) + +(defun slime-highlight-edits-init-buffer () + (make-local-variable 'after-change-functions) + (add-to-list 'after-change-functions + 'slime-highlight-edits) + (add-to-list 'slime-before-compile-functions + 'slime-highlight-edits-compile-hook)) + +(defun slime-highlight-edits-reset-buffer () + (setq after-change-functions + (remove 'slime-highlight-edits after-change-functions)) + (slime-remove-edits (point-min) (point-max))) + +;; FIXME: what's the LEN arg for? +(defun slime-highlight-edits (beg end &optional len) + (save-match-data + (when (and (slime-connected-p) + (not (slime-inside-comment-p beg end)) + (not (slime-only-whitespace-p beg end))) + (let ((overlay (make-overlay beg end))) + (overlay-put overlay 'face 'slime-highlight-edits-face) + (overlay-put overlay 'slime-edit t))))) + +(defun slime-remove-edits (start end) + "Delete the existing Slime edit hilights in the current buffer." + (save-excursion + (goto-char start) + (while (< (point) end) + (dolist (o (overlays-at (point))) + (when (overlay-get o 'slime-edit) + (delete-overlay o))) + (goto-char (next-overlay-change (point)))))) + +(defun slime-highlight-edits-compile-hook (start end) + (when slime-highlight-edits-mode + (let ((start (save-excursion (goto-char start) + (skip-chars-backward " \t\n\r") + (point))) + (end (save-excursion (goto-char end) + (skip-chars-forward " \t\n\r") + (point)))) + (slime-remove-edits start end)))) + +(defun slime-inside-comment-p (beg end) + "Is the region from BEG to END in a comment?" + (save-excursion + (goto-char beg) + (let* ((hs-c-start-regexp ";\\|#|") + (comment (hs-inside-comment-p))) + (and comment + (destructuring-bind (cbeg cend) comment + (<= end cend)))))) + +(defun slime-only-whitespace-p (beg end) + "Contains the region from BEG to END only whitespace?" + (save-excursion + (goto-char beg) + (skip-chars-forward " \n\t\r" end) + (<= end (point)))) + +(defun slime-highlight-edits-mode-on () (slime-highlight-edits-mode 1)) + +(defun slime-highlight-edits-init () + (add-hook 'slime-mode-hook 'slime-highlight-edits-mode-on)) + +(defun slime-highlight-edits-unload () + (remove-hook 'slime-mode-hook 'slime-highlight-edits-mode-on)) + +(provide 'slime-highlight-edits) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,378 @@ +;;; slime-parse.el --- parsing of Common Lisp source code +;; +;; Authors: Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> +;; Tobias C. Rittweiler <tcr(a)freebits.de> +;; and others +;; +;; License: GNU GPL (same license as Emacs) +;; + +(defun slime-incomplete-form-at-point () + "Looks for a ``raw form spec'' around point to be processed by +SWANK::PARSE-FORM-SPEC. It is similiar to +SLIME-INCOMPLETE-SEXP-AT-POINT but looks further back than just +one sexp to find out the context." + (multiple-value-bind (operators arg-indices points) + (slime-enclosing-form-specs) + (if (null operators) + "" + (let ((op (first operators))) + (destructure-case (slime-ensure-list op) + ((:declaration declspec) op) + ((:type-specifier typespec) op) + (t (slime-ensure-list + (save-excursion (goto-char (first points)) + (slime-parse-sexp-at-point + (1+ (first arg-indices))))))))))) + +;; XXX: unused function +(defun slime-cl-symbol-external-ref-p (symbol) + "Does SYMBOL refer to an external symbol? +FOO:BAR is an external reference. +FOO::BAR is not, and nor is BAR." + (let ((name (if (stringp symbol) symbol (symbol-name symbol)))) + (and (string-match ":" name) + (not (string-match "::" name))))) + +(defun slime-cl-symbol-name (symbol) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match ":\$[^:]*\$$" n) + (let ((symbol-part (match-string 1 n))) + (if (string-match "^|\$.*\$|$" symbol-part) + (match-string 1 symbol-part) + symbol-part)) + n))) + +(defun slime-cl-symbol-package (symbol &optional default) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match "^\$[^:]*\$:" n) + (match-string 1 n) + default))) + +;; XXX: unused function +(defun slime-qualify-cl-symbol (symbol-or-name) + "Like `slime-qualify-cl-symbol-name', but interns the result." + (intern (slime-qualify-cl-symbol-name symbol-or-name))) + +(defun slime-qualify-cl-symbol-name (symbol-or-name) + "Return a package-qualified symbol-name that indicates the CL symbol +SYMBOL. If SYMBOL doesn't already have a package prefix the current +package is used." + (let ((s (if (stringp symbol-or-name) + symbol-or-name + (symbol-name symbol-or-name)))) + (if (slime-cl-symbol-package s) + s + (format "%s::%s" + (let* ((package (slime-current-package))) + ;; package is a string like ":cl-user" or "CL-USER". + (if (and package (string-match "^:" package)) + (substring package 1) + package)) + (slime-cl-symbol-name s))))) + + +(defun slime-parse-sexp-at-point (&optional n skip-blanks-p) + "Return the sexp at point as a string, otherwise nil. +If N is given and greater than 1, a list of all such sexps +following the sexp at point is returned. (If there are not +as many sexps as N, a list with < N sexps is returned.) + +If SKIP-BLANKS-P is true, leading whitespaces &c are skipped. +" + (interactive "p") (or n (setq n 1)) + (flet ((sexp-at-point (first-choice) + (let ((string (if (eq first-choice :symbol-first) + (or (slime-symbol-name-at-point) + (thing-at-point 'sexp)) + (or (thing-at-point 'sexp) + (slime-symbol-name-at-point))))) + (if string (substring-no-properties string) nil)))) + ;; `thing-at-point' depends upon the current syntax table; otherwise + ;; keywords like `:foo' are not recognized as sexps. (This function + ;; may be called from temporary buffers etc.) + (with-syntax-table lisp-mode-syntax-table + (save-excursion + (when skip-blanks-p ; e.g. `( foo bat)' where point is after ?$. + (slime-forward-blanks)) + (let ((result nil)) + (dotimes (i n) + ;; `foo(bar baz)' where point is at ?\( or ?$. + (if (and (char-after) (member (char-syntax (char-after)) '(?$ ?$ ?\'))) + (push (sexp-at-point :sexp-first) result) + (push (sexp-at-point :symbol-first) result)) + (ignore-errors (forward-sexp) (slime-forward-blanks)) + (save-excursion + (unless (slime-point-moves-p (ignore-errors (forward-sexp))) + (return)))) + (if (slime-length= result 1) + (first result) + (nreverse result))))))) + +(defun slime-incomplete-sexp-at-point (&optional n) + (interactive "p") (or n (setq n 1)) + (buffer-substring-no-properties (save-excursion (backward-up-list n) (point)) + (point))) + + +(defun slime-parse-extended-operator-name (user-point forms indices points) + "Assume that point is directly at the operator that should be parsed. +USER-POINT is the value of `point' where the user was looking at. +OPS, INDICES and POINTS are updated to reflect the new values after +parsing, and are then returned back as multiple values." + ;; OPS, INDICES and POINTS are like the finally returned values of + ;; SLIME-ENCLOSING-FORM-SPECS except that they're in reversed order, + ;; i.e. the leftmost (that is the latest) operator comes + ;; first. + (save-excursion + (ignore-errors + (let* ((current-op (first (first forms))) + (op-name (upcase (slime-cl-symbol-name current-op))) + (assoc (assoc op-name slime-extended-operator-name-parser-alist)) + (entry (cdr assoc)) + (parser (if (and entry (listp entry)) + (apply (first entry) (rest entry)) + entry))) + (ignore-errors + (forward-char (1+ (length current-op))) + (slime-forward-blanks)) + (when parser + (multiple-value-setq (forms indices points) + (funcall parser op-name user-point forms indices points)))))) + (values forms indices points)) + + +(defvar slime-extended-operator-name-parser-alist + '(("MAKE-INSTANCE" . (slime-make-extended-operator-parser/look-ahead 1)) + ("MAKE-CONDITION" . (slime-make-extended-operator-parser/look-ahead 1)) + ("ERROR" . (slime-make-extended-operator-parser/look-ahead 1)) + ("SIGNAL" . (slime-make-extended-operator-parser/look-ahead 1)) + ("WARN" . (slime-make-extended-operator-parser/look-ahead 1)) + ("CERROR" . (slime-make-extended-operator-parser/look-ahead 2)) + ("CHANGE-CLASS" . (slime-make-extended-operator-parser/look-ahead 2)) + ("DEFMETHOD" . (slime-make-extended-operator-parser/look-ahead 1)) + ("APPLY" . (slime-make-extended-operator-parser/look-ahead 1)) + ("DECLARE" . slime-parse-extended-operator/declare) + ("DECLAIM" . slime-parse-extended-operator/declare) + ("PROCLAIM" . slime-parse-extended-operator/declare))) + +(defun slime-make-extended-operator-parser/look-ahead (steps) + "Returns a parser that parses the current operator at point +plus STEPS-many additional sexps on the right side of the +operator." + (lexical-let ((n steps)) + #'(lambda (name user-point current-forms current-indices current-points) + (let ((old-forms (rest current-forms))) + (let* ((args (slime-ensure-list (slime-parse-sexp-at-point n))) + (arg-specs (mapcar #'slime-make-form-spec-from-string args))) + (setq current-forms (cons `(,name ,@arg-specs) old-forms)))) + (values current-forms current-indices current-points) + ))) + +(defun slime-parse-extended-operator/declare + (name user-point current-forms current-indices current-points) + (when (string= (thing-at-point 'char) "(") + (let ((orig-point (point))) + (goto-char user-point) + (slime-end-of-symbol) + ;; Head of CURRENT-FORMS is "declare" at this point, but we're + ;; interested in what comes next. + (let* ((decl-ops (rest current-forms)) + (decl-indices (rest current-indices)) + (decl-points (rest current-points)) + (decl-pos (1- (first decl-points))) + (nesting (slime-nesting-until-point decl-pos)) + (declspec-str (concat (slime-incomplete-sexp-at-point nesting) + (make-string nesting ?\))))) + (save-match-data ; `(declare ((foo ...))' or `(declare (type (foo ...)))' ? + (if (or (eql 0 (string-match "\\s-*(\$(\\(\\sw\\|\\s_\\|\\s-\$*)\\))$" + declspec-str)) + (eql 0 (string-match "\\s-*(type\\s-*\$(\\(\\sw\\|\\s_\\|\\s-\$*)\\))$" + declspec-str))) + (let* ((typespec-str (match-string 1 declspec-str)) + (typespec (slime-make-form-spec-from-string typespec-str))) + (setq current-forms (list `(:type-specifier ,typespec))) + (setq current-indices (list (second decl-indices))) + (setq current-points (list (second decl-points)))) + (let ((declspec (slime-make-form-spec-from-string declspec-str))) + (setq current-forms (list `(,name) `(:declaration ,declspec))) + (setq current-indices (list (first current-indices) + (first decl-indices))) + (setq current-points (list (first current-points) + (first decl-points))))))))) + (values current-forms current-indices current-points)) + +(defun slime-nesting-until-point (target-point) + "Returns the nesting level between current point and TARGET-POINT. +If TARGET-POINT could not be reached, 0 is returned. (As a result +TARGET-POINT should always be placed just before a `?\('.)" + (save-excursion + (let ((nesting 0)) + (while (> (point) target-point) + (backward-up-list) + (incf nesting)) + (if (= (point) target-point) + nesting + 0)))) + +(defun slime-make-form-spec-from-string (string &optional strip-operator-p) + "If STRIP-OPERATOR-P is T and STRING is the string +representation of a form, the string representation of this form +is stripped from the form. This can be important to avoid mutual +recursion between this function, `slime-enclosing-form-specs' and +`slime-parse-extended-operator-name'. + +Examples: + + \"(foo (bar 1 (baz :quux)) 'toto)\" + + => (\"foo\" (\"bar\" \"1\" (\"baz\" \":quux\")) \"'toto\") +" + (cond ((slime-length= string 0) "") + ((equal string "()") '()) + (t + (with-temp-buffer + ;; Do NEVER ever try to activate `lisp-mode' here with + ;; `slime-use-autodoc-mode' enabled, as this function is used + ;; to compute the current autodoc itself. + (erase-buffer) + (insert string) + (when strip-operator-p ; `(OP arg1 arg2 ...)' ==> `(arg1 arg2 ...)' + (goto-char (point-min)) + (when (string= (thing-at-point 'char) "(") + (ignore-errors (forward-char 1) + (forward-sexp) + (slime-forward-blanks)) + (delete-region (point-min) (point)) + (insert "("))) + (goto-char (1- (point-max))) ; `(OP arg1 ... argN|)' + (multiple-value-bind (forms indices points) + (slime-enclosing-form-specs 1) + (if (null forms) + string + (let ((n (first (last indices)))) + (goto-char (1+ (point-min))) ; `(|OP arg1 ... argN)' + (mapcar #'(lambda (s) + (assert (not (equal s string))) ; trap against + (slime-make-form-spec-from-string s)) ; endless recursion. + (slime-ensure-list + (slime-parse-sexp-at-point (1+ n) t)))))))))) + + +(defun slime-enclosing-form-specs (&optional max-levels) + "Return the list of ``raw form specs'' of all the forms +containing point from right to left. + +As a secondary value, return a list of indices: Each index tells +for each corresponding form spec in what argument position the +user's point is. + +As tertiary value, return the positions of the operators that are +contained in the returned form specs. + +When MAX-LEVELS is non-nil, go up at most this many levels of +parens. + +\(See SWANK::PARSE-FORM-SPEC for more information about what +exactly constitutes a ``raw form specs'') + +Examples: + + A return value like the following + + (values ((\"quux\") (\"bar\") (\"foo\")) (3 2 1) (p1 p2 p3)) + + can be interpreted as follows: + + The user point is located in the 3rd argument position of a + form with the operator name \"quux\" (which starts at P1.) + + This form is located in the 2nd argument position of a form + with the operator name \"bar\" (which starts at P2.) + + This form again is in the 1st argument position of a form + with the operator name \"foo\" (which itself begins at P3.) + + For instance, the corresponding buffer content could have looked + like `(foo (bar arg1 (quux 1 2 |' where `|' denotes point. +" + (let ((level 1) + (parse-sexp-lookup-properties nil) + (initial-point (point)) + (result '()) (arg-indices '()) (points '())) + ;; The expensive lookup of syntax-class text properties is only + ;; used for interactive balancing of #<...> in presentations; we + ;; do not need them in navigating through the nested lists. + ;; This speeds up this function significantly. + (ignore-errors + (save-excursion + ;; Make sure we get the whole thing at point. + (if (not (slime-inside-string-p)) + (slime-end-of-symbol) + (slime-beginning-of-string) + (forward-sexp)) + (save-restriction + ;; Don't parse more than 20000 characters before point, so we don't spend + ;; too much time. + (narrow-to-region (max (point-min) (- (point) 20000)) (point-max)) + (narrow-to-region (save-excursion (beginning-of-defun) (point)) + (min (1+ (point)) (point-max))) + (while (or (not max-levels) + (<= level max-levels)) + (let ((arg-index 0)) + ;; Move to the beginning of the current sexp if not already there. + (if (or (and (char-after) + (member (char-syntax (char-after)) '(?\( ?'))) + (member (char-syntax (char-before)) '(?\ ?>))) + (incf arg-index)) + (ignore-errors (backward-sexp 1)) + (while (and (< arg-index 64) + (ignore-errors (backward-sexp 1) + (> (point) (point-min)))) + (incf arg-index)) + (backward-up-list 1) + (when (member (char-syntax (char-after)) '(?\( ?')) + (incf level) + (forward-char 1) + (let ((name (slime-symbol-name-at-point))) + (cond + (name + (save-restriction + (widen) ; to allow looking-ahead/back in extended parsing. + (multiple-value-bind (new-result new-indices new-points) + (slime-parse-extended-operator-name initial-point + (cons `(,name) result) ; minimal form spec + (cons arg-index arg-indices) + (cons (point) points)) + (setq result new-result) + (setq arg-indices new-indices) + (setq points new-points)))) + (t + (push nil result) + (push arg-index arg-indices) + (push (point) points)))) + (backward-up-list 1))))))) + (values + (nreverse result) + (nreverse arg-indices) + (nreverse points)))) + + +(defun slime-ensure-list (thing) + (if (listp thing) thing (list thing))) + +(defun slime-inside-string-p () + (let* ((toplevel-begin (save-excursion (beginning-of-defun) (point))) + (parse-result (parse-partial-sexp toplevel-begin (point))) + (inside-string-p (nth 3 parse-result)) + (string-start-pos (nth 8 parse-result))) + (and inside-string-p string-start-pos))) + +(defun slime-beginning-of-string () + (let ((string-start-pos (slime-inside-string-p))) + (if string-start-pos + (goto-char string-start-pos) + (error "We're not within a string")))) + +(provide 'slime-parse) + Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-presentation-streams.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-presentation-streams.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-presentation-streams.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,29 @@ +;;; swank-presentation-streams.el --- Streams that allow attaching object identities +;;; to portions of output +;;; +;;; Authors: Alan Ruttenberg <alanr-l(a)mumble.net> +;;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> +;;; Helmut Eller <heller(a)common-lisp.net> +;;; +;;; License: GNU GPL (same license as Emacs) +;;; +;;; Installation +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-presentation-streams))) +;; + + +;;; Initialization + +(require 'slime-presentations) + +(add-hook 'slime-connected-hook 'slime-install-presentation-streams) + +(defun slime-install-presentation-streams () + (slime-eval-async '(swank:swank-require :swank-presentation-streams))) + +(provide 'slime-presentation-streams) + Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,649 @@ +;;; swank-presentations.el --- imitat LispM' presentations +;;; +;;; Authors: Alan Ruttenberg <alanr-l(a)mumble.net> +;;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> +;;; +;;; License: GNU GPL (same license as Emacs) +;;; +;;; Installation +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-presentations))) +;; + +(defface slime-repl-output-mouseover-face + (if (featurep 'xemacs) + '((t (:bold t))) + (if (slime-face-inheritance-possible-p) + '((t + (:box + (:line-width 1 :color "black" :style released-button) + :inherit + slime-repl-inputed-output-face))) + '((t (:box (:line-width 1 :color "black")))))) + "Face for Lisp output in the SLIME REPL, when the mouse hovers over it" + :group 'slime-repl) + +(defface slime-repl-inputed-output-face + '((((class color) (background light)) (:foreground "Red")) + (((class color) (background dark)) (:foreground "Red")) + (t (:slant italic))) + "Face for the result of an evaluation in the SLIME REPL." + :group 'slime-repl) + +;; FIXME: This conditional is not right - just used because the code +;; here does not work in XEmacs. +(when (boundp 'text-property-default-nonsticky) + (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky + :test 'equal) + (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky + :test 'equal)) + +(make-variable-buffer-local + (defvar slime-presentation-start-to-point (make-hash-table))) + +(defun slime-mark-presentation-start (id &optional target) + "Mark the beginning of a presentation with the given ID. +TARGET can be nil (regular process output) or :repl-result." + (setf (gethash id slime-presentation-start-to-point) + ;; We use markers because text can also be inserted before this presentation. + ;; (Output arrives while we are writing presentations within REPL results.) + (copy-marker (slime-output-target-marker target) nil))) + +(defun slime-mark-presentation-start-handler (process string) + (if (and string (string-match "<\$[-0-9]+\$" string)) + (let* ((match (substring string (match-beginning 1) (match-end 1))) + (id (car (read-from-string match)))) + (slime-mark-presentation-start id)))) + +(defun slime-mark-presentation-end (id &optional target) + "Mark the end of a presentation with the given ID. +TARGET can be nil (regular process output) or :repl-result." + (let ((start (gethash id slime-presentation-start-to-point))) + (remhash id slime-presentation-start-to-point) + (when start + (let* ((marker (slime-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (with-current-buffer buffer + (let ((end (marker-position marker))) + (slime-add-presentation-properties start end + id nil))))))) + +(defun slime-mark-presentation-end-handler (process string) + (if (and string (string-match ">\$[-0-9]+\$" string)) + (let* ((match (substring string (match-beginning 1) (match-end 1))) + (id (car (read-from-string match)))) + (slime-mark-presentation-end id)))) + +(defstruct slime-presentation text id) + +(defvar slime-presentation-syntax-table + (let ((table (copy-syntax-table lisp-mode-syntax-table))) + ;; We give < and > parenthesis syntax, so that #< ... > is treated + ;; as a balanced expression. This allows to use C-M-k, C-M-SPC, + ;; etc. to deal with a whole presentation. (For Lisp mode, this + ;; is not desirable, since we do not wish to get a mismatched + ;; paren highlighted everytime we type < or >.) + (modify-syntax-entry ?< "(>" table) + (modify-syntax-entry ?> ")<" table) + table) + "Syntax table for presentations.") + +(defun slime-add-presentation-properties (start end id result-p) + "Make the text between START and END a presentation with ID. +RESULT-P decides whether a face for a return value or output text is used." + (let* ((text (buffer-substring-no-properties start end)) + (presentation (make-slime-presentation :text text :id id))) + (let ((inhibit-modification-hooks t)) + (add-text-properties start end + `(modification-hooks (slime-after-change-function) + insert-in-front-hooks (slime-after-change-function) + insert-behind-hooks (slime-after-change-function) + syntax-table ,slime-presentation-syntax-table + rear-nonsticky t)) + ;; Use the presentation as the key of a text property + (case (- end start) + (0) + (1 + (add-text-properties start end + `(slime-repl-presentation ,presentation + ,presentation :start-and-end))) + (t + (add-text-properties start (1+ start) + `(slime-repl-presentation ,presentation + ,presentation :start)) + (when (> (- end start) 2) + (add-text-properties (1+ start) (1- end) + `(,presentation :interior))) + (add-text-properties (1- end) end + `(slime-repl-presentation ,presentation + ,presentation :end)))) + ;; Also put an overlay for the face and the mouse-face. This enables + ;; highlighting of nested presentations. However, overlays get lost + ;; when we copy a presentation; their removal is also not undoable. + ;; In these cases the mouse-face text properties need to take over --- + ;; but they do not give nested highlighting. + (slime-ensure-presentation-overlay start end presentation)))) + +(defun slime-ensure-presentation-overlay (start end presentation) + (unless (find presentation (overlays-at start) + :key (lambda (overlay) + (overlay-get overlay 'slime-repl-presentation))) + (let ((overlay (make-overlay start end (current-buffer) t nil))) + (overlay-put overlay 'slime-repl-presentation presentation) + (overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face) + (overlay-put overlay 'help-echo + (if (eq major-mode 'slime-repl-mode) + "mouse-2: copy to input; mouse-3: menu" + "mouse-2: inspect; mouse-3: menu")) + (overlay-put overlay 'face 'slime-repl-inputed-output-face) + (overlay-put overlay 'keymap slime-presentation-map)))) + +(defun slime-remove-presentation-properties (from to presentation) + (let ((inhibit-read-only t)) + (remove-text-properties from to + `(,presentation t syntax-table t rear-nonsticky t)) + (when (eq (get-text-property from 'slime-repl-presentation) presentation) + (remove-text-properties from (1+ from) `(slime-repl-presentation t))) + (when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation) + (remove-text-properties (1- to) to `(slime-repl-presentation t))) + (dolist (overlay (overlays-at from)) + (when (eq (overlay-get overlay 'slime-repl-presentation) presentation) + (delete-overlay overlay))))) + +(defun slime-insert-presentation (string output-id &optional rectangle) + "Insert STRING in current buffer and mark it as a presentation +corresponding to OUTPUT-ID. If RECTANGLE is true, indent multi-line +strings to line up below the current point." + (flet ((insert-it () + (if rectangle + (slime-insert-indented string) + (insert string)))) + (let ((start (point))) + (insert-it) + (slime-add-presentation-properties start (point) output-id t)))) + +(defun slime-presentation-whole-p (presentation start end &optional object) + (let ((object (or object (current-buffer)))) + (string= (etypecase object + (buffer (with-current-buffer object + (buffer-substring-no-properties start end))) + (string (substring-no-properties object start end))) + (slime-presentation-text presentation)))) + +(defun slime-presentations-around-point (point &optional object) + (let ((object (or object (current-buffer)))) + (loop for (key value . rest) on (text-properties-at point object) by 'cddr + when (slime-presentation-p key) + collect key))) + +(defun slime-presentation-start-p (tag) + (memq tag '(:start :start-and-end))) + +(defun slime-presentation-stop-p (tag) + (memq tag '(:end :start-and-end))) + +(defun* slime-presentation-start (point presentation + &optional (object (current-buffer))) + "Find start of `presentation' at `point' in `object'. +Return buffer index and whether a start-tag was found." + (let* ((this-presentation (get-text-property point presentation object))) + (while (not (slime-presentation-start-p this-presentation)) + (let ((change-point (previous-single-property-change + point presentation object))) + (unless change-point + (return-from slime-presentation-start + (values (etypecase object + (buffer (with-current-buffer object 1)) + (string 0)) + nil))) + (setq this-presentation (get-text-property change-point + presentation object)) + (unless this-presentation + (return-from slime-presentation-start + (values point nil))) + (setq point change-point))) + (values point t))) + +(defun* slime-presentation-end (point presentation + &optional (object (current-buffer))) + "Find end of presentation at `point' in `object'. Return buffer +index (after last character of the presentation) and whether an +end-tag was found." + (let* ((this-presentation (get-text-property point presentation object))) + (while (not (slime-presentation-stop-p this-presentation)) + (let ((change-point (next-single-property-change + point presentation object))) + (unless change-point + (return-from slime-presentation-end + (values (etypecase object + (buffer (with-current-buffer object (point-max))) + (string (length object))) + nil))) + (setq point change-point) + (setq this-presentation (get-text-property point + presentation object)))) + (if this-presentation + (let ((after-end (next-single-property-change point + presentation object))) + (if (not after-end) + (values (etypecase object + (buffer (with-current-buffer object (point-max))) + (string (length object))) + t) + (values after-end t))) + (values point nil)))) + +(defun* slime-presentation-bounds (point presentation + &optional (object (current-buffer))) + "Return start index and end index of `presentation' around `point' +in `object', and whether the presentation is complete." + (multiple-value-bind (start good-start) + (slime-presentation-start point presentation object) + (multiple-value-bind (end good-end) + (slime-presentation-end point presentation object) + (values start end + (and good-start good-end + (slime-presentation-whole-p presentation + start end object)))))) + +(defun slime-presentation-around-point (point &optional object) + "Return presentation, start index, end index, and whether the +presentation is complete." + (let ((object (or object (current-buffer))) + (innermost-presentation nil) + (innermost-start 0) + (innermost-end most-positive-fixnum)) + (dolist (presentation (slime-presentations-around-point point object)) + (multiple-value-bind (start end whole-p) + (slime-presentation-bounds point presentation object) + (when whole-p + (when (< (- end start) (- innermost-end innermost-start)) + (setq innermost-start start + innermost-end end + innermost-presentation presentation))))) + (values innermost-presentation + innermost-start innermost-end))) + +(defun slime-presentation-around-or-before-point (point &optional object) + (let ((object (or object (current-buffer)))) + (multiple-value-bind (presentation start end whole-p) + (slime-presentation-around-point point object) + (if presentation + (values presentation start end whole-p) + (slime-presentation-around-point (1- point) object))))) + +(defun* slime-for-each-presentation-in-region (from to function &optional (object (current-buffer))) + "Call `function' with arguments `presentation', `start', `end', +`whole-p' for every presentation in the region `from'--`to' in the +string or buffer `object'." + (flet ((handle-presentation (presentation point) + (multiple-value-bind (start end whole-p) + (slime-presentation-bounds point presentation object) + (funcall function presentation start end whole-p)))) + ;; Handle presentations active at `from'. + (dolist (presentation (slime-presentations-around-point from object)) + (handle-presentation presentation from)) + ;; Use the `slime-repl-presentation' property to search for new presentations. + (let ((point from)) + (while (< point to) + (setq point (next-single-property-change point 'slime-repl-presentation object to)) + (let* ((presentation (get-text-property point 'slime-repl-presentation object)) + (status (get-text-property point presentation object))) + (when (slime-presentation-start-p status) + (handle-presentation presentation point))))))) + +;; XEmacs compatibility hack, from message by Stephen J. Turnbull on +;; xemacs-beta(a)xemacs.org of 18 Mar 2002 +(unless (boundp 'undo-in-progress) + (defvar undo-in-progress nil + "Placeholder defvar for XEmacs compatibility from SLIME.") + (defadvice undo-more (around slime activate) + (let ((undo-in-progress t)) ad-do-it))) + +(defun slime-after-change-function (start end &rest ignore) + "Check all presentations within and adjacent to the change. +When a presentation has been altered, change it to plain text." + (let ((inhibit-modification-hooks t)) + (let ((real-start (max 1 (1- start))) + (real-end (min (1+ (buffer-size)) (1+ end))) + (any-change nil)) + ;; positions around the change + (slime-for-each-presentation-in-region + real-start real-end + (lambda (presentation from to whole-p) + (cond + (whole-p + (slime-ensure-presentation-overlay from to presentation)) + ((not undo-in-progress) + (slime-remove-presentation-properties from to + presentation) + (setq any-change t))))) + (when any-change + (undo-boundary))))) + +(defun slime-presentation-around-click (event) + "Return the presentation around the position of the mouse-click EVENT. +If there is no presentation, signal an error. +Also return the start position, end position, and buffer of the presentation." + (when (and (featurep 'xemacs) (not (button-press-event-p event))) + (error "Command must be bound to a button-press-event")) + (let ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event)))) + (window (if (featurep 'xemacs) (event-window event) (caadr event)))) + (with-current-buffer (window-buffer window) + (multiple-value-bind (presentation start end) + (slime-presentation-around-point point) + (unless presentation + (error "No presentation at click")) + (values presentation start end (current-buffer)))))) + +(defun slime-copy-or-inspect-presentation-at-mouse (event) + (interactive "e") ; no "@" -- we don't want to select the clicked-at window + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (if (with-current-buffer buffer + (eq major-mode 'slime-repl-mode)) + (slime-copy-presentation-at-mouse event) + (slime-inspect-presentation-at-mouse event)))) + +(defun slime-inspect-presentation-at-mouse (event) + (interactive "e") + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (let ((reset-p + (with-current-buffer buffer + (not (eq major-mode 'slime-inspector-mode))))) + (slime-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p) + 'slime-open-inspector)))) + +(defun slime-copy-presentation-at-mouse (event) + (interactive "e") + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (let ((presentation-text + (with-current-buffer buffer + (buffer-substring start end)))) + (unless (eql major-mode 'slime-repl-mode) + (slime-switch-to-output-buffer)) + (flet ((do-insertion () + (when (not (string-match "\\s-" + (buffer-substring (1- (point)) (point)))) + (insert " ")) + (insert presentation-text) + (when (and (not (eolp)) (not (looking-at "\\s-"))) + (insert " ")))) + (if (>= (point) slime-repl-prompt-start-mark) + (do-insertion) + (save-excursion + (goto-char (point-max)) + (do-insertion))))))) + +(defun slime-copy-presentation-at-mouse-to-point (event) + (interactive "e") + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (let ((presentation-text + (with-current-buffer buffer + (buffer-substring start end)))) + (when (not (string-match "\\s-" + (buffer-substring (1- (point)) (point)))) + (insert " ")) + (insert presentation-text) + (slime-after-change-function (point) (point)) + (when (and (not (eolp)) (not (looking-at "\\s-"))) + (insert " "))))) + +(defun slime-copy-presentation-at-mouse-to-kill-ring (event) + (interactive "e") + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (let ((presentation-text + (with-current-buffer buffer + (buffer-substring start end)))) + (kill-new presentation-text)))) + +(defun slime-describe-presentation-at-mouse (event) + (interactive "@e") + (multiple-value-bind (presentation) (slime-presentation-around-click event) + (slime-eval-describe + `(swank::describe-to-string + (swank::lookup-presented-object ',(slime-presentation-id presentation)))))) + +(defun slime-pretty-print-presentation-at-mouse (event) + (interactive "@e") + (multiple-value-bind (presentation) (slime-presentation-around-click event) + (slime-eval-describe + `(swank::swank-pprint + (cl:list + (swank::lookup-presented-object ',(slime-presentation-id presentation))))))) + +(defvar slime-presentation-map (make-sparse-keymap)) + +(define-key slime-presentation-map [mouse-2] 'slime-copy-or-inspect-presentation-at-mouse) +(define-key slime-presentation-map [mouse-3] 'slime-presentation-menu) + +(when (featurep 'xemacs) + (define-key slime-presentation-map [button2] 'slime-copy-or-inspect-presentation-at-mouse) + (define-key slime-presentation-map [button3] 'slime-presentation-menu)) + +;; protocol for handling up a menu. +;; 1. Send lisp message asking for menu choices for this object. +;; Get back list of strings. +;; 2. Let used choose +;; 3. Call back to execute menu choice, passing nth and string of choice + +(defun slime-menu-choices-for-presentation (presentation buffer from to choice-to-lambda) + "Return a menu for `presentation' at `from'--`to' in `buffer', suitable for `x-popup-menu'." + (let* ((what (slime-presentation-id presentation)) + (choices (with-current-buffer buffer + (slime-eval + `(swank::menu-choices-for-presentation-id ',what))))) + (flet ((savel (f) ;; IMPORTANT - xemacs can't handle lambdas in x-popup-menu. So give them a name + (let ((sym (gensym))) + (setf (gethash sym choice-to-lambda) f) + sym))) + (etypecase choices + (list + `(,(format "Presentation %s" what) + ("" + ("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse)) + ("Describe" . ,(savel 'slime-describe-presentation-at-mouse)) + ("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse)) + ("Copy to REPL" . ,(savel 'slime-copy-presentation-at-mouse)) + ("Copy to kill ring" . ,(savel 'slime-copy-presentation-at-mouse-to-kill-ring)) + ,@(unless buffer-read-only + `(("Copy to point" . ,(savel 'slime-copy-presentation-at-mouse-to-point)))) + ,@(let ((nchoice 0)) + (mapcar + (lambda (choice) + (incf nchoice) + (cons choice + (savel `(lambda () + (interactive) + (slime-eval + '(swank::execute-menu-choice-for-presentation-id + ',what ,nchoice ,(nth (1- nchoice) choices))))))) + choices))))) + (symbol ; not-present + (with-current-buffer buffer + (slime-remove-presentation-properties from to presentation)) + (sit-for 0) ; allow redisplay + `("Object no longer recorded" + ("sorry" . ,(if (featurep 'xemacs) nil '(nil))))))))) + +(defun slime-presentation-menu (event) + (interactive "e") + (let* ((point (if (featurep 'xemacs) (event-point event) + (posn-point (event-end event)))) + (window (if (featurep 'xemacs) (event-window event) (caadr event))) + (buffer (window-buffer window)) + (choice-to-lambda (make-hash-table))) + (multiple-value-bind (presentation from to) + (with-current-buffer buffer + (slime-presentation-around-point point)) + (unless presentation + (error "No presentation at event position")) + (let ((menu (slime-menu-choices-for-presentation + presentation buffer from to choice-to-lambda))) + (let ((choice (x-popup-menu event menu))) + (when choice + (call-interactively (gethash choice choice-to-lambda)))))))) + +(defun slime-presentation-expression (presentation) + "Return a string that contains a CL s-expression accessing +the presented object." + (let ((id (slime-presentation-id presentation))) + (etypecase id + (number + ;; Make sure it works even if *read-base* is not 10. + (format "(swank:get-repl-result #10r%d)" id)) + (list + ;; for frame variables and inspector parts + (format "(swank:get-repl-result '%s)" id))))) + +(defun slime-buffer-substring-with-reified-output (start end) + (let ((str-props (buffer-substring start end)) + (str-no-props (buffer-substring-no-properties start end))) + (slime-reify-old-output str-props str-no-props))) + +(defun slime-reify-old-output (str-props str-no-props) + (let ((pos (slime-property-position 'slime-repl-presentation str-props))) + (if (null pos) + str-no-props + (multiple-value-bind (presentation start-pos end-pos whole-p) + (slime-presentation-around-point pos str-props) + (if (not presentation) + str-no-props + (concat (substring str-no-props 0 pos) + ;; Eval in the reader so that we play nice with quote. + ;; -luke (19/May/2005) + "#." (slime-presentation-expression presentation) + (slime-reify-old-output (substring str-props end-pos) + (substring str-no-props end-pos)))))))) + + + +(defun slime-repl-grab-old-output (replace) + "Resend the old REPL output at point. +If replace it non-nil the current input is replaced with the old +output; otherwise the new input is appended." + (multiple-value-bind (presentation beg end) + (slime-presentation-around-or-before-point (point)) + (let ((old-output (buffer-substring beg end))) ;;keep properties + ;; Append the old input or replace the current input + (cond (replace (goto-char slime-repl-input-start-mark)) + (t (goto-char slime-repl-input-end-mark) + (unless (eq (char-before) ?\ ) + (insert " ")))) + (delete-region (point) slime-repl-input-end-mark) + (let ((inhibit-read-only t)) + (insert old-output))))) + + +;;; hook functions (hard to isolate stuff) + +(defun slime-dispatch-presentation-event (event) + (destructure-case event + ((:presentation-start id &optional target) + (slime-mark-presentation-start id target) + t) + ((:presentation-end id &optional target) + (slime-mark-presentation-end id target) + t) + (t nil))) + +(defun slime-presentation-write (string &optional target) + (case target + ((nil) ; Regular process output + (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (slime-propertize-region '(face slime-repl-output-face + rear-nonsticky (face)) + (insert string)) + (set-marker slime-output-end (point)) + (when (and (= (point) slime-repl-prompt-start-mark) + (not (bolp))) + (insert "\n") + (set-marker slime-output-end (1- (point)))) + (if (< slime-repl-input-start-mark (point)) + (set-marker slime-repl-input-start-mark + (point)))))) + (:repl-result + (with-current-buffer (slime-output-buffer) + (let ((marker (slime-output-target-marker target))) + (goto-char marker) + (let ((result-start (point))) + (slime-propertize-region `(face slime-repl-result-face + rear-nonsticky (face)) + (insert string)) + ;; Move the input-start marker after the REPL result. + (set-marker marker (point)))))) + (t + (let* ((marker (slime-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (when buffer + (with-current-buffer buffer + (save-excursion + ;; Insert STRING at MARKER, then move MARKER behind + ;; the insertion. + (goto-char marker) + (insert-before-markers string) + (set-marker marker (point))))))))) + +(defun slime-presentation-current-input (&optional until-point-p) + "Return the current input as string. +The input is the region from after the last prompt to the end of +buffer. Presentations of old results are expanded into code." + (slime-buffer-substring-with-reified-output slime-repl-input-start-mark + (if (and until-point-p + (<= (point) slime-repl-input-end-mark)) + (point) + slime-repl-input-end-mark))) +(defun slime-presentation-on-return-pressed () + (cond ((and (car (slime-presentation-around-or-before-point (point))) + (< (point) slime-repl-input-start-mark)) + (slime-repl-grab-old-output end-of-input) + (slime-repl-recenter-if-needed) + t) + (t nil))) + +(defun slime-presentation-on-stream-open (stream) + (require 'bridge) + (defun bridge-insert (process output) + (slime-output-filter process (or output ""))) + (install-bridge) + (setq bridge-destination-insert nil) + (setq bridge-source-insert nil) + (setq bridge-handlers + (list* '("<" . slime-mark-presentation-start-handler) + '(">" . slime-mark-presentation-end-handler) + bridge-handlers))) + +(defun slime-clear-presentations () + (slime-eval-async `(swank:clear-repl-results))) + +;;; Initialization + +(defun slime-presentations-init () + (add-hook 'slime-repl-mode-hook + (lambda () + ;; Respect the syntax text properties of presentation. + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (add-local-hook 'after-change-functions + 'slime-after-change-function))) + (add-hook 'slime-event-hooks 'slime-dispatch-presentation-event) + (setq slime-write-string-function 'slime-presentation-write) + (add-hook 'slime-repl-return-hooks 'slime-presentation-on-return-pressed) + (add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input) + (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open) + (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations) + (add-hook 'slime-connected-hook 'slime-install-presentations)) + +(defun slime-install-presentations () + (slime-eval-async '(swank:swank-require :swank-presentations))) + +(slime-presentations-init) + +(provide 'slime-presentations) Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-references.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-references.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-references.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,135 @@ +;;; slime-references.el --- Clickable references to documentation (SBCL only) +;; +;; Authors: Christophe Rhodes <csr21(a)cantab.net> +;; Luke Gorrie <luke(a)bluetail.com> +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; + +(defcustom slime-sbcl-manual-root "http://www.sbcl.org/manual/" + "*The base URL of the SBCL manual, for documentation lookup." + :type 'string + :group 'slime-mode) + +(defface sldb-reference-face + (list (list t '(:underline t))) + "Face for references." + :group 'slime-debugger) + +(defun slime-note.references (note) + (plist-get note :references)) + +(defun slime-tree-print-with-references (tree) + ;; for SBCL-style references + (slime-tree-default-printer tree) + (when-let (note (plist-get (slime-tree.plist tree) 'note)) + (when-let (references (slime-note.references note)) + (terpri (current-buffer)) + (princ "See also:" (current-buffer)) + (terpri (current-buffer)) + (slime-tree-insert-references references)))) + +(defun slime-tree-insert-references (references) + "Insert documentation references from a condition. +See SWANK-BACKEND:CONDITION-REFERENCES for the datatype." + (loop for refs on references + for ref = (car refs) + do + (destructuring-bind (where type what) ref + ;; FIXME: this is poorly factored, and shares some code and + ;; data with sldb that it shouldn't: notably + ;; sldb-reference-face. Probably the names of + ;; sldb-reference-foo should be altered to be not sldb + ;; specific. + (insert " " (sldb-format-reference-source where) ", ") + (slime-insert-propertized (sldb-reference-properties ref) + (sldb-format-reference-node what)) + (insert (format " [%s]" type)) + (when (cdr refs) + (terpri (current-buffer)))))) + + +;;;;; SLDB references (rather SBCL specific) + +(defun sldb-insert-references (references) + "Insert documentation references from a condition. +See SWANK-BACKEND:CONDITION-REFERENCES for the datatype." + (dolist (ref references) + (destructuring-bind (where type what) ref + (insert "\n" (sldb-format-reference-source where) ", ") + (slime-insert-propertized (sldb-reference-properties ref) + (sldb-format-reference-node what)) + (insert (format " [%s]" type))))) + +(defun sldb-reference-properties (reference) + "Return the properties for a reference. +Only add clickability to properties we actually know how to lookup." + (destructuring-bind (where type what) reference + (if (or (and (eq where :sbcl) (eq type :node)) + (and (eq where :ansi-cl) + (memq type '(:function :special-operator :macro + :section :glossary :issue)))) + `(sldb-default-action + sldb-lookup-reference + ;; FIXME: this is a hack! slime-compiler-notes and sldb are a + ;; little too intimately entwined. + slime-compiler-notes-default-action sldb-lookup-reference + sldb-reference ,reference + face sldb-reference-face + mouse-face highlight)))) + +(defun sldb-format-reference-source (where) + (case where + (:amop "The Art of the Metaobject Protocol") + (:ansi-cl "Common Lisp Hyperspec") + (:sbcl "SBCL Manual") + (t (format "%S" where)))) + +(defun sldb-format-reference-node (what) + (if (listp what) + (mapconcat #'prin1-to-string what ".") + what)) + +(defun sldb-lookup-reference () + "Browse the documentation reference at point." + (destructuring-bind (where type what) + (get-text-property (point) 'sldb-reference) + (case where + (:ansi-cl + (case type + (:section + (browse-url (funcall common-lisp-hyperspec-section-fun what))) + (:glossary + (browse-url (funcall common-lisp-glossary-fun what))) + (:issue + (browse-url (funcall 'common-lisp-issuex what))) + (t + (hyperspec-lookup what)))) + (t + (let ((url (format "%s%s.html" slime-sbcl-manual-root + (subst-char-in-string ?\ ?\- what)))) + (browse-url url)))))) + +(defun sldb-maybe-insert-references (extra) + (destructure-case extra + ((:references references) + (when references + (insert "\nSee also:") + (slime-with-rigid-indentation 2 + (sldb-insert-references references))) + t) + (t nil))) + + +;;; Initialization + +(defun slime-references-init () + (setq slime-tree-printer 'slime-tree-print-with-references) + (add-hook 'sldb-extras-hooks 'sldb-maybe-insert-references)) + +(defun slime-references-unload () + (setq slime-tree-printer 'slime-tree-default-printer) + (remove-hook 'sldb-extras-hooks 'sldb-maybe-insert-references)) + +(provide 'slime-references) Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-scratch.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-scratch.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-scratch.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,48 @@ +;;; slime-scratch.el --- imitate Emacs' *scratch* buffer +;; +;; Author: Helmut Eller <heller(a)common-lisp.net> +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path ".../slime/contrib") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-scratch))) +;; + + +;;; Code + +(defvar slime-scratch-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map lisp-mode-map) + map)) + +(defun slime-scratch () + (interactive) + (slime-switch-to-scratch-buffer)) + +(defun slime-switch-to-scratch-buffer () + (set-buffer (slime-scratch-buffer)) + (unless (eq (current-buffer) (window-buffer)) + (pop-to-buffer (current-buffer) t))) + +(defun slime-scratch-buffer () + "Return the scratch buffer, create it if necessary." + (or (get-buffer "*slime-scratch*") + (with-current-buffer (get-buffer-create "*slime-scratch*") + (lisp-mode) + (use-local-map slime-scratch-mode-map) + (slime-mode t) + (current-buffer)))) + +(slime-define-keys slime-scratch-mode-map + ("\C-j" 'slime-eval-print-last-expression)) + +(defun slime-scratch-init () + (def-slime-selector-method ?s + "*slime-scratch* buffer." + (slime-scratch-buffer))) + +(provide 'slime-scratch) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-tramp.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-tramp.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-tramp.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,55 @@ +;;; slime-tramp.el --- Filename translations for tramp +;; +;; Authors: Marco Baringer <mb(a)bese.it> +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path ".../slime/contrib") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-tramp))) +;; + +(defun slime-make-tramp-file-name (username remote-host lisp-filename) + "Old (with multi-hops) tramp compatability function" + (require 'tramp) + (if (boundp 'tramp-multi-methods) + (tramp-make-tramp-file-name nil nil + username + remote-host + lisp-filename) + (tramp-make-tramp-file-name nil + username + remote-host + lisp-filename))) + +(defun* slime-create-filename-translator (&key machine-instance + remote-host + username) + "Creates a three element list suitable for push'ing onto +slime-filename-translations which uses Tramp to load files on +hostname using username. MACHINE-INSTANCE is a required +parameter, REMOTE-HOST defaults to MACHINE-INSTANCE and USERNAME +defaults to (user-login-name). + +MACHINE-INSTANCE is the value returned by slime-machine-instance, +which is just the value returned by cl:machine-instance on the +remote lisp. REMOTE-HOST is the fully qualified domain name (or +just the IP) of the remote machine. USERNAME is the username we +should login with. +The functions created here expect your tramp-default-method or + tramp-default-method-alist to be setup correctly." + (lexical-let ((remote-host (or remote-host machine-instance)) + (username (or username (user-login-name)))) + (list (concat "^" machine-instance "$") + (lambda (emacs-filename) + (tramp-file-name-localname + (tramp-dissect-file-name emacs-filename))) + `(lambda (lisp-filename) + (slime-make-tramp-file-name + ,username + ,remote-host + lisp-filename))))) + +(provide 'slime-tramp) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,91 @@ +;;; slime-typeout-frame.el --- display some message in a dedicated frame +;; +;; Author: Luke Gorrie <luke(a)synap.se> +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-typeout-frame))) +;; + + +;;;; Typeout frame + +;; When a "typeout frame" exists it is used to display certain +;; messages instead of the echo area or pop-up windows. + +(defvar slime-typeout-window nil + "The current typeout window.") + +(defvar slime-typeout-frame-properties + '((height . 10) (minibuffer . nil)) + "The typeout frame properties (passed to `make-frame').") + +(defun slime-typeout-active-p () + (and slime-typeout-window + (window-live-p slime-typeout-window))) + +(defun slime-typeout-message-aux (format-string &rest format-args) + (slime-ensure-typeout-frame) + (with-current-buffer (window-buffer slime-typeout-window) + (let ((msg (apply #'format format-string format-args))) + (unless (string= msg "") + (erase-buffer) + (insert msg))))) + +(defun slime-typeout-message (format-string &rest format-args) + (apply #'slime-typeout-message-aux format-string format-args) + ;; Disable the timer for autodoc temporarily, as it would overwrite + ;; the current typeout message otherwise. + (when (and (featurep 'slime-autodoc) slime-autodoc-mode) + (slime-autodoc-stop-timer) + (add-hook 'pre-command-hook #'slime-autodoc-start-timer))) + +(defun slime-make-typeout-frame () + "Create a frame for displaying messages (e.g. arglists)." + (interactive) + (let ((frame (make-frame slime-typeout-frame-properties))) + (save-selected-window + (select-window (frame-selected-window frame)) + (switch-to-buffer "*SLIME-Typeout*") + (setq slime-typeout-window (selected-window))))) + +(defun slime-ensure-typeout-frame () + "Create the typeout frame unless it already exists." + (interactive) + (unless (slime-typeout-active-p) + (slime-make-typeout-frame))) + +(defun slime-typeout-autodoc-message (doc) + ;; No need for refreshing per `slime-autodoc-pre-command-refresh-echo-area'. + (setq slime-autodoc-last-message "") + (slime-typeout-message-aux "%s" doc)) + + +;;; Initialization + +(defvar slime-typeout-frame-unbind-stack ()) + +(defun slime-typeout-frame-init () + (add-hook 'slime-connected-hook 'slime-ensure-typeout-frame) + (loop for (var value) in + '((slime-message-function slime-typeout-message) + (slime-background-message-function slime-typeout-message) + (slime-autodoc-message-function slime-typeout-autodoc-message)) + do (slime-typeout-frame-init-var var value))) + +(defun slime-typeout-frame-init-var (var value) + (push (list var (if (boundp var) (symbol-value var) 'slime-unbound)) + slime-typeout-frame-unbind-stack) + (set var value)) + +(defun slime-typeout-frame-unload () + (remove-hook 'slime-connected-hook 'slime-ensure-typeout-frame) + (loop for (var value) in slime-typeout-frame-unbind-stack + do (cond ((eq var 'slime-unbound) (makunbound var)) + (t (set var value))))) + +(provide 'slime-typeout-frame) Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,104 @@ +;;; slime-xref-browser.el --- xref browsing with tree-widget +;; +;; Author: Rui Patroc�nio <rui.patrocinio(a)netvisao.pt> +;; Licencse: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-xref-browser))) +;; + + +;;;; classes browser + +(defun slime-expand-class-node (widget) + (or (widget-get widget :args) + (let ((name (widget-get widget :tag))) + (loop for kid in (slime-eval `(swank:mop :subclasses ,name)) + collect `(tree-widget :tag ,kid + :dynargs slime-expand-class-node + :has-children t))))) + +(defun slime-browse-classes (name) + "Read the name of a class and show its subclasses." + (interactive (list (slime-read-symbol-name "Class Name: "))) + (slime-call-with-browser-setup + "*slime class browser*" (slime-current-package) "Class Browser" + (lambda () + (widget-create 'tree-widget :tag name + :dynargs 'slime-expand-class-node + :has-echildren t)))) + +(defvar slime-browser-map nil + "Keymap for tree widget browsers") + +(require 'tree-widget) +(unless slime-browser-map + (setq slime-browser-map (make-sparse-keymap)) + (set-keymap-parent slime-browser-map widget-keymap) + (define-key slime-browser-map "q" 'bury-buffer)) + +(defun slime-call-with-browser-setup (buffer package title fn) + (switch-to-buffer buffer) + (kill-all-local-variables) + (setq slime-buffer-package package) + (let ((inhibit-read-only t)) (erase-buffer)) + (widget-insert title "\n\n") + (save-excursion + (funcall fn)) + (lisp-mode-variables t) + (slime-mode t) + (use-local-map slime-browser-map) + (widget-setup)) + + +;;;; Xref browser + +(defun slime-fetch-browsable-xrefs (type name) + "Return a list ((LABEL DSPEC)). +LABEL is just a string for display purposes. +DSPEC can be used to expand the node." + (let ((xrefs '())) + (loop for (_file . specs) in (slime-eval `(swank:xref ,type ,name)) do + (loop for (dspec . _location) in specs do + (let ((exp (ignore-errors (read (downcase dspec))))) + (cond ((and (consp exp) (eq 'flet (car exp))) + ;; we can't expand FLET references so they're useless + ) + ((and (consp exp) (eq 'method (car exp))) + ;; this isn't quite right, but good enough for now + (push (list dspec (string (second exp))) xrefs)) + (t + (push (list dspec dspec) xrefs)))))) + xrefs)) + +(defun slime-expand-xrefs (widget) + (or (widget-get widget :args) + (let* ((type (widget-get widget :xref-type)) + (dspec (widget-get widget :xref-dspec)) + (xrefs (slime-fetch-browsable-xrefs type dspec))) + (loop for (label dspec) in xrefs + collect `(tree-widget :tag ,label + :xref-type ,type + :xref-dspec ,dspec + :dynargs slime-expand-xrefs + :has-children t))))) + +(defun slime-browse-xrefs (name type) + "Show the xref graph of a function in a tree widget." + (interactive + (list (slime-read-from-minibuffer "Name: " + (slime-symbol-name-at-point)) + (read (completing-read "Type: " (slime-bogus-completion-alist + '(":callers" ":callees" ":calls")) + nil t ":")))) + (slime-call-with-browser-setup + "*slime xref browser*" (slime-current-package) "Xref Browser" + (lambda () + (widget-create 'tree-widget :tag name :xref-type type :xref-dspec name + :dynargs 'slime-expand-xrefs :has-echildren t)))) + +(provide 'slime-xref-browser) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,1217 @@ +;;; swank-arglists.lisp --- arglist related code ?? +;; +;; Authors: Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> +;; Tobias C. Rittweiler <tcr(a)freebits.de> +;; and others +;; +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-c-p-c)) + +(defun valid-operator-symbol-p (symbol) + "Is SYMBOL the name of a function, a macro, or a special-operator?" + (or (fboundp symbol) + (macro-function symbol) + (special-operator-p symbol) + (eq symbol 'declare))) + +(defun valid-operator-name-p (string) + "Is STRING the name of a function, macro, or special-operator?" + (let ((symbol (parse-symbol string))) + (valid-operator-symbol-p symbol))) + +(defslimefun arglist-for-echo-area (raw-specs &key arg-indices + print-right-margin print-lines) + "Return the arglist for the first valid ``form spec'' in +RAW-SPECS. A ``form spec'' is a superset of functions, macros, +special-ops, declarations and type specifiers. + +For more information about the format of ``raw form specs'' and +``form specs'', please see PARSE-FORM-SPEC." + (handler-case + (with-buffer-syntax () + (multiple-value-bind (form-spec position newly-interned-symbols) + (parse-first-valid-form-spec raw-specs #'read-conversatively-for-autodoc) + (unwind-protect + (when form-spec + (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) + (unless (eql arglist :not-available) + (multiple-value-bind (type operator arguments) + (split-form-spec form-spec) + (declare (ignore arguments)) + (multiple-value-bind (stringified-arglist) + (decoded-arglist-to-string + arglist + :operator operator + :print-right-margin print-right-margin + :print-lines print-lines + :highlight (let ((index (nth position arg-indices))) + ;; don't highlight the operator + (and index (not (zerop index)) index))) + ;; Post formatting: + (case type + (:type-specifier (format nil "[Typespec] ~A" stringified-arglist)) + (:declaration + (locally (declare (special *arglist-pprint-bindings*)) + (with-bindings *arglist-pprint-bindings* + (let ((op (%find-declaration-operator raw-specs position))) + (if op + (format nil "(~A ~A)" op stringified-arglist) + (format nil "[Declaration] ~A" stringified-arglist)))))) + (t stringified-arglist))))))) + (mapc #'unintern-in-home-package newly-interned-symbols)))) + (error (cond) + (format nil "ARGLIST (error): ~A" cond)) + )) + +(defun %find-declaration-operator (raw-specs position) + (let ((op-rawspec (nth (1+ position) raw-specs))) + (first (parse-form-spec op-rawspec #'read-conversatively-for-autodoc)))) + +(defvar *arglist-dummy* (cons :dummy nil)) + +(defun read-conversatively-for-autodoc (string) + "Tries to find the symbol that's represented by STRING. + +If it can't, this either means that STRING does not represent a +symbol, or that the symbol behind STRING would have to be freshly +interned. Because this function is supposed to be called from the +automatic arglist display stuff from Slime, interning freshly +symbols is a big no-no. + +In such a case (that no symbol could be found), the object +*ARGLIST-DUMMY* is returned instead, which works as a placeholder +datum for subsequent logics to rely on." + (let* ((string (string-left-trim '(#\Space #\Tab #\Newline) string)) + (quoted? (eql (aref string 0) #\'))) + (multiple-value-bind (symbol found?) + (parse-symbol (if quoted? (subseq string 1) string)) + (if found? + (if quoted? `(quote ,symbol) symbol) + *arglist-dummy*)))) + + +(defun parse-form-spec (raw-spec &optional reader) + "Takes a raw (i.e. unparsed) form spec from SLIME and returns a +proper form spec for further processing within SWANK. Returns NIL +if RAW-SPEC could not be parsed. Symbols that had to be interned +in course of the conversion, are returned as secondary return value. + +A ``raw form spec'' can be either: + + i) a list of strings representing a Common Lisp form + + ii) a list of strings as of i), but which additionally + contains other raw form specs + + iii) one of: + + a) (:declaration declspec) + + where DECLSPEC is a raw form spec. + + b) (:type-specifier typespec) + + where TYPESPEC is a raw form spec. + + +A ``form spec'' is either + + 1) a normal Common Lisp form + + 2) a Common Lisp form with a list as its CAR specifying what namespace + the operator is supposed to be interpreted in: + + a) ((:declaration decl-identifier) declarg1 declarg2 ...) + + b) ((:type-specifier typespec-op) typespec-arg1 typespec-arg2 ...) + + +Examples: + + (\"defmethod\") => (defmethod) + (\"cl:defmethod\") => (cl:defmethod) + (\"defmethod\" \"print-object\") => (defmethod print-object) + + (\"foo\" (\"bar\" (\"quux\")) \"baz\" => (foo (bar (quux)) baz) + + (:declaration \"optimize\" \"(optimize)\") => ((:declaration optimize)) + (:declaration \"type\" \"(type string)\") => ((:declaration type) string) + (:type-specifier \"float\" \"(float)\") => ((:type-specifier float)) + (:type-specifier \"float\" \"(float 0 100)\") => ((:type-specifier float) 0 100) +" + (flet ((parse-extended-spec (raw-extension extension-flag) + (when (and (stringp (first raw-extension)) ; (:DECLARATION (("a" "b" ("c")) "d")) + (nth-value 1 (parse-symbol (first raw-extension)))) + (multiple-value-bind (extension introduced-symbols) + (read-form-spec raw-extension reader) + (unless (recursively-empty-p extension) ; (:DECLARATION (())) &c. + (destructuring-bind (identifier &rest args) extension + (values `((,extension-flag ,identifier) ,@args) + introduced-symbols))))))) + (when (consp raw-spec) + (destructure-case raw-spec + ((:declaration raw-declspec) + (parse-extended-spec raw-declspec :declaration)) + ((:type-specifier raw-typespec) + (parse-extended-spec raw-typespec :type-specifier)) + (t + (when (every #'(lambda (x) (or (stringp x) (consp x))) raw-spec) + (destructuring-bind (raw-operator &rest raw-args) raw-spec + (multiple-value-bind (operator found?) (parse-symbol raw-operator) + (when (and found? (valid-operator-symbol-p operator)) + (multiple-value-bind (parsed-args introduced-symbols) + (read-form-spec raw-args reader) + (values `(,operator ,@parsed-args) introduced-symbols))))))))))) + + +(defun split-form-spec (spec) + "Returns all three relevant information a ``form spec'' +contains: the operator type, the operator, and the operands." + (destructuring-bind (operator-designator &rest arguments) spec + (multiple-value-bind (type operator) + (if (listp operator-designator) + (values (first operator-designator) (second operator-designator)) + (values :function operator-designator)) ; functions, macros, special ops + (values type operator arguments)))) ; are all fbound. + +(defun parse-first-valid-form-spec (raw-specs &optional reader) + "Returns the first parsed form spec in RAW-SPECS that can +successfully be parsed. Additionally returns that spec's position +as secondary, and all newly interned symbols as tertiary return +value." + (loop for raw-spec in raw-specs + for pos upfrom 0 + do (multiple-value-bind (spec symbols) (parse-form-spec raw-spec reader) + (when spec (return (values spec pos symbols)))))) + +(defun read-form-spec (spec &optional reader) + "Turns the ``raw form spec'' SPEC into a proper Common Lisp +form. As secondary return value, it returns all the symbols that +had to be newly interned during the conversion. + +READER is a function that takes a string, and returns two values: +the Common Lisp datum that the string represents, a flag whether +the returned datum is a symbol and has been newly interned in +some package. + +If READER is not explicitly given, the function READ-SOFTLY is +used instead." + (when spec + (with-buffer-syntax () + (call-with-ignored-reader-errors + #'(lambda () + (let ((result) (newly-interned-symbols) (ok)) + (unwind-protect + (dolist (element spec (setq ok t)) + (etypecase element + (string + (multiple-value-bind (sexp newly-interned?) + (funcall (or reader 'read-softly) element) + (push sexp result) + (when newly-interned? + (push sexp newly-interned-symbols)))) + (cons + (multiple-value-bind (read-spec interned-symbols) + (read-form-spec element) + (push read-spec result) + (setf newly-interned-symbols + (append interned-symbols + newly-interned-symbols)))))) + (unless ok + (mapc #'unintern-in-home-package newly-interned-symbols))) + (values (nreverse result) + (nreverse newly-interned-symbols)))))))) + +(defun unintern-in-home-package (symbol) + (unintern symbol (symbol-package symbol))) + +(defun read-softly (string) + "Returns two values: + + 1. the object resulting from READing STRING. + + 2. T if the object is a symbol that had to be newly interned + in some package. (This does not work for symbols in + compound forms like lists or vectors.)" + (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string) + (if found? + (values symbol nil) + (let ((sexp (read-from-string string))) + (values sexp + (when (symbolp sexp) + (prog1 t + ;; assert that PARSE-SYMBOL didn't parse incorrectly. + (assert (and (equal symbol-name (symbol-name sexp)) + (eq package (symbol-package sexp))))))))))) + + +(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p)) + provided-args ; list of the provided actual arguments + required-args ; list of the required arguments + optional-args ; list of the optional arguments + key-p ; whether &key appeared + keyword-args ; list of the keywords + rest ; name of the &rest or &body argument (if any) + body-p ; whether the rest argument is a &body + allow-other-keys-p ; whether &allow-other-keys appeared + aux-args ; list of &aux variables + any-p ; whether &any appeared + any-args ; list of &any arguments [*] + known-junk ; &whole, &environment + unknown-junk) ; unparsed stuff + +;;; +;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp, +;;; and is only used to describe certain arglists that cannot be +;;; described in another way. +;;; +;;; &ANY is very similiar to &KEY but while &KEY is based upon +;;; the idea of a plist (key1 value1 key2 value2), &ANY is a +;;; cross between &OPTIONAL, &KEY and *FEATURES* lists: +;;; +;;; a) (&ANY :A :B :C) means that you can provide any (non-null) +;;; set consisting of the keywords `:A', `:B', or `:C' in +;;; the arglist. E.g. (:A) or (:C :B :A). +;;; +;;; (This is not restricted to keywords only, but any self-evaluating +;;; expression is allowed.) +;;; +;;; b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can +;;; provide any (non-null) set consisting of lists where +;;; the CAR of the list is one of `key1', `key2', or `key3'. +;;; E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23)) +;;; +;;; +;;; For example, a) let us describe the situations of EVAL-WHEN as +;;; +;;; (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body) +;;; +;;; and b) let us describe the optimization qualifiers that are valid +;;; in the declaration specifier `OPTIMIZE': +;;; +;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...)) +;;; + +(defun print-arglist (arglist &key operator highlight) + (let ((index 0) + (need-space nil)) + (labels ((print-arg (arg) + (typecase arg + (arglist ; destructuring pattern + (print-arglist arg)) + (optional-arg + (princ (encode-optional-arg arg))) + (keyword-arg + (let ((enc-arg (encode-keyword-arg arg))) + (etypecase enc-arg + (symbol (princ enc-arg)) + ((cons symbol) + (pprint-logical-block (nil nil :prefix "(" :suffix ")") + (princ (car enc-arg)) + (write-char #\space) + (pprint-fill *standard-output* (cdr enc-arg) nil))) + ((cons cons) + (pprint-logical-block (nil nil :prefix "(" :suffix ")") + (pprint-logical-block (nil nil :prefix "(" :suffix ")") + (prin1 (caar enc-arg)) + (write-char #\space) + (print-arg (keyword-arg.arg-name arg))) + (unless (null (cdr enc-arg)) + (write-char #\space)) + (pprint-fill *standard-output* (cdr enc-arg) nil)))))) + (t ; required formal or provided actual arg + (if (keywordp arg) + (prin1 arg) ; for &ANY args. + (princ arg))))) + (print-space () + (ecase need-space + ((nil)) + ((:miser) + (write-char #\space) + (pprint-newline :miser)) + ((t) + (write-char #\space) + (pprint-newline :fill))) + (setq need-space t)) + (print-with-space (obj) + (print-space) + (print-arg obj)) + (print-with-highlight (arg &optional (index-ok-p #'=)) + (print-space) + (cond + ((and highlight (funcall index-ok-p index highlight)) + (princ "===> ") + (print-arg arg) + (princ " <===")) + (t + (print-arg arg))) + (incf index))) + (pprint-logical-block (nil nil :prefix "(" :suffix ")") + (when operator + (print-with-highlight operator) + (setq need-space :miser)) + (mapc #'print-with-highlight + (arglist.provided-args arglist)) + (mapc #'print-with-highlight + (arglist.required-args arglist)) + (when (arglist.optional-args arglist) + (print-with-space '&optional) + (mapc #'print-with-highlight + (arglist.optional-args arglist))) + (when (arglist.key-p arglist) + (print-with-space '&key) + (mapc #'print-with-space + (arglist.keyword-args arglist))) + (when (arglist.allow-other-keys-p arglist) + (print-with-space '&allow-other-keys)) + (when (arglist.any-args arglist) + (print-with-space '&any) + (mapc #'print-with-space + (arglist.any-args arglist))) + (cond ((not (arglist.rest arglist))) + ((arglist.body-p arglist) + (print-with-space '&body) + (print-with-highlight (arglist.rest arglist) #'<=)) + (t + (print-with-space '&rest) + (print-with-highlight (arglist.rest arglist) #'<=))) + (mapc #'print-with-space + (arglist.unknown-junk arglist)))))) + +(defvar *arglist-pprint-bindings* + '((*print-case* . :downcase) + (*print-pretty* . t) + (*print-circle* . nil) + (*print-readably* . nil) + (*print-level* . 10) + (*print-length* . 20) + (*print-escape* . nil))) ; no package qualifiers. + +(defun decoded-arglist-to-string (arglist + &key operator highlight (package *package*) + print-right-margin print-lines) + "Print the decoded ARGLIST for display in the echo area. The +argument name are printed without package qualifiers and pretty +printing of (function foo) as #'foo is suppressed. If HIGHLIGHT is +non-nil, it must be the index of an argument; highlight this argument. +If OPERATOR is non-nil, put it in front of the arglist." + (with-output-to-string (*standard-output*) + (with-standard-io-syntax + (with-bindings *arglist-pprint-bindings* + (let ((*package* package) + (*print-right-margin* print-right-margin) + (*print-lines* print-lines)) + (print-arglist arglist :operator operator :highlight highlight)))))) + +(defslimefun variable-desc-for-echo-area (variable-name) + "Return a short description of VARIABLE-NAME, or NIL." + (with-buffer-syntax () + (let ((sym (parse-symbol variable-name))) + (if (and sym (boundp sym)) + (let ((*print-pretty* nil) (*print-level* 4) + (*print-length* 10) (*print-circle* t)) + (format nil "~A => ~A" sym (symbol-value sym))))))) + +(defun decode-required-arg (arg) + "ARG can be a symbol or a destructuring pattern." + (etypecase arg + (symbol arg) + (list (decode-arglist arg)))) + +(defun encode-required-arg (arg) + (etypecase arg + (symbol arg) + (arglist (encode-arglist arg)))) + +(defstruct (keyword-arg + (:conc-name keyword-arg.) + (:constructor make-keyword-arg (keyword arg-name default-arg))) + keyword + arg-name + default-arg) + +(defun decode-keyword-arg (arg) + "Decode a keyword item of formal argument list. +Return three values: keyword, argument name, default arg." + (cond ((symbolp arg) + (make-keyword-arg (intern (symbol-name arg) keyword-package) + arg + nil)) + ((and (consp arg) + (consp (car arg))) + (make-keyword-arg (caar arg) + (decode-required-arg (cadar arg)) + (cadr arg))) + ((consp arg) + (make-keyword-arg (intern (symbol-name (car arg)) keyword-package) + (car arg) + (cadr arg))) + (t + (error "Bad keyword item of formal argument list")))) + +(defun encode-keyword-arg (arg) + (cond + ((arglist-p (keyword-arg.arg-name arg)) + ;; Destructuring pattern + (let ((keyword/name (list (keyword-arg.keyword arg) + (encode-required-arg + (keyword-arg.arg-name arg))))) + (if (keyword-arg.default-arg arg) + (list keyword/name + (keyword-arg.default-arg arg)) + (list keyword/name)))) + ((eql (intern (symbol-name (keyword-arg.arg-name arg)) + keyword-package) + (keyword-arg.keyword arg)) + (if (keyword-arg.default-arg arg) + (list (keyword-arg.arg-name arg) + (keyword-arg.default-arg arg)) + (keyword-arg.arg-name arg))) + (t + (let ((keyword/name (list (keyword-arg.keyword arg) + (keyword-arg.arg-name arg)))) + (if (keyword-arg.default-arg arg) + (list keyword/name + (keyword-arg.default-arg arg)) + (list keyword/name)))))) + +(progn + (assert (equalp (decode-keyword-arg 'x) + (make-keyword-arg :x 'x nil))) + (assert (equalp (decode-keyword-arg '(x t)) + (make-keyword-arg :x 'x t))) + (assert (equalp (decode-keyword-arg '((:x y))) + (make-keyword-arg :x 'y nil))) + (assert (equalp (decode-keyword-arg '((:x y) t)) + (make-keyword-arg :x 'y t)))) + +(defstruct (optional-arg + (:conc-name optional-arg.) + (:constructor make-optional-arg (arg-name default-arg))) + arg-name + default-arg) + +(defun decode-optional-arg (arg) + "Decode an optional item of a formal argument list. +Return an OPTIONAL-ARG structure." + (etypecase arg + (symbol (make-optional-arg arg nil)) + (list (make-optional-arg (decode-required-arg (car arg)) + (cadr arg))))) + +(defun encode-optional-arg (optional-arg) + (if (or (optional-arg.default-arg optional-arg) + (arglist-p (optional-arg.arg-name optional-arg))) + (list (encode-required-arg + (optional-arg.arg-name optional-arg)) + (optional-arg.default-arg optional-arg)) + (optional-arg.arg-name optional-arg))) + +(progn + (assert (equalp (decode-optional-arg 'x) + (make-optional-arg 'x nil))) + (assert (equalp (decode-optional-arg '(x t)) + (make-optional-arg 'x t)))) + +(define-modify-macro nreversef () nreverse "Reverse the list in PLACE.") + +(defun decode-arglist (arglist) + "Parse the list ARGLIST and return an ARGLIST structure." + (let ((mode nil) + (result (make-arglist))) + (dolist (arg arglist) + (cond + ((eql mode '&unknown-junk) + ;; don't leave this mode -- we don't know how the arglist + ;; after unknown lambda-list keywords is interpreted + (push arg (arglist.unknown-junk result))) + ((eql arg '&allow-other-keys) + (setf (arglist.allow-other-keys-p result) t)) + ((eql arg '&key) + (setf (arglist.key-p result) t + mode arg)) + ((member arg '(&optional &rest &body &aux)) + (setq mode arg)) + ((member arg '(&whole &environment)) + (setq mode arg) + (push arg (arglist.known-junk result))) + ((and (symbolp arg) + (string= (symbol-name arg) (string '#:&ANY))) ; may be interned + (setf (arglist.any-p result) t) ; in any *package*. + (setq mode '&any)) + ((member arg lambda-list-keywords) + (setq mode '&unknown-junk) + (push arg (arglist.unknown-junk result))) + (t + (ecase mode + (&key + (push (decode-keyword-arg arg) + (arglist.keyword-args result))) + (&optional + (push (decode-optional-arg arg) + (arglist.optional-args result))) + (&body + (setf (arglist.body-p result) t + (arglist.rest result) arg)) + (&rest + (setf (arglist.rest result) arg)) + (&aux + (push (decode-optional-arg arg) + (arglist.aux-args result))) + ((nil) + (push (decode-required-arg arg) + (arglist.required-args result))) + ((&whole &environment) + (setf mode nil) + (push arg (arglist.known-junk result))) + (&any + (push arg (arglist.any-args result))))))) + (nreversef (arglist.required-args result)) + (nreversef (arglist.optional-args result)) + (nreversef (arglist.keyword-args result)) + (nreversef (arglist.aux-args result)) + (nreversef (arglist.any-args result)) + (nreversef (arglist.known-junk result)) + (nreversef (arglist.unknown-junk result)) + (assert (or (and (not (arglist.key-p result)) (not (arglist.any-p result))) + (exactly-one-p (arglist.key-p result) (arglist.any-p result)))) + result)) + +(defun encode-arglist (decoded-arglist) + (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist)) + (when (arglist.optional-args decoded-arglist) + '(&optional)) + (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist)) + (when (arglist.key-p decoded-arglist) + '(&key)) + (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist)) + (when (arglist.allow-other-keys-p decoded-arglist) + '(&allow-other-keys)) + (when (arglist.any-args decoded-arglist) + `(&any ,(a)(arglist.any-args decoded-arglist))) + (cond ((not (arglist.rest decoded-arglist)) + '()) + ((arglist.body-p decoded-arglist) + `(&body ,(arglist.rest decoded-arglist))) + (t + `(&rest ,(arglist.rest decoded-arglist)))) + (when (arglist.aux-args decoded-arglist) + `(&aux ,(arglist.aux-args decoded-arglist))) + (arglist.known-junk decoded-arglist) + (arglist.unknown-junk decoded-arglist))) + +(defun arglist-keywords (arglist) + "Return the list of keywords in ARGLIST. +As a secondary value, return whether &allow-other-keys appears." + (let ((decoded-arglist (decode-arglist arglist))) + (values (arglist.keyword-args decoded-arglist) + (arglist.allow-other-keys-p decoded-arglist)))) + +(defun methods-keywords (methods) + "Collect all keywords in the arglists of METHODS. +As a secondary value, return whether &allow-other-keys appears somewhere." + (let ((keywords '()) + (allow-other-keys nil)) + (dolist (method methods) + (multiple-value-bind (kw aok) + (arglist-keywords + (swank-mop:method-lambda-list method)) + (setq keywords (remove-duplicates (append keywords kw) + :key #'keyword-arg.keyword) + allow-other-keys (or allow-other-keys aok)))) + (values keywords allow-other-keys))) + +(defun generic-function-keywords (generic-function) + "Collect all keywords in the methods of GENERIC-FUNCTION. +As a secondary value, return whether &allow-other-keys appears somewhere." + (methods-keywords + (swank-mop:generic-function-methods generic-function))) + +(defun applicable-methods-keywords (generic-function arguments) + "Collect all keywords in the methods of GENERIC-FUNCTION that are +applicable for argument of CLASSES. As a secondary value, return +whether &allow-other-keys appears somewhere." + (methods-keywords + (multiple-value-bind (amuc okp) + (swank-mop:compute-applicable-methods-using-classes + generic-function (mapcar #'class-of arguments)) + (if okp + amuc + (compute-applicable-methods generic-function arguments))))) + +(defun decoded-arglist-to-template-string (decoded-arglist package &key (prefix "(") (suffix ")")) + (with-output-to-string (*standard-output*) + (with-standard-io-syntax + (let ((*package* package) (*print-case* :downcase) + (*print-pretty* t) (*print-circle* nil) (*print-readably* nil) + (*print-level* 10) (*print-length* 20)) + (print-decoded-arglist-as-template decoded-arglist + :prefix prefix + :suffix suffix))))) + +(defun print-decoded-arglist-as-template (decoded-arglist &key + (prefix "(") (suffix ")")) + (pprint-logical-block (nil nil :prefix prefix :suffix suffix) + (let ((first-p t)) + (flet ((space () + (unless first-p + (write-char #\space) + (pprint-newline :fill)) + (setq first-p nil)) + (print-arg-or-pattern (arg) + (etypecase arg + (symbol (if (keywordp arg) (prin1 arg) (princ arg))) + (string (princ arg)) + (list (princ arg)) + (arglist (print-decoded-arglist-as-template arg))))) + (dolist (arg (arglist.required-args decoded-arglist)) + (space) + (print-arg-or-pattern arg)) + (dolist (arg (arglist.optional-args decoded-arglist)) + (space) + (princ "[") + (print-arg-or-pattern (optional-arg.arg-name arg)) + (princ "]")) + (dolist (keyword-arg (arglist.keyword-args decoded-arglist)) + (space) + (let ((arg-name (keyword-arg.arg-name keyword-arg)) + (keyword (keyword-arg.keyword keyword-arg))) + (format t "~W " + (if (keywordp keyword) keyword `',keyword)) + (print-arg-or-pattern arg-name))) + (dolist (any-arg (arglist.any-args decoded-arglist)) + (space) + (print-arg-or-pattern any-arg)) + (when (and (arglist.rest decoded-arglist) + (or (not (arglist.keyword-args decoded-arglist)) + (arglist.allow-other-keys-p decoded-arglist))) + (if (arglist.body-p decoded-arglist) + (pprint-newline :mandatory) + (space)) + (format t "~A..." (arglist.rest decoded-arglist))))) + (pprint-newline :fill))) + + +(defgeneric extra-keywords (operator &rest args) + (:documentation "Return a list of extra keywords of OPERATOR (a +symbol) when applied to the (unevaluated) ARGS. +As a secondary value, return whether other keys are allowed. +As a tertiary value, return the initial sublist of ARGS that was needed +to determine the extra keywords.")) + +(defun keywords-of-operator (operator) + "Return a list of KEYWORD-ARGs that OPERATOR accepts. +This function is useful for writing EXTRA-KEYWORDS methods for +user-defined functions which are declared &ALLOW-OTHER-KEYS and which +forward keywords to OPERATOR." + (let ((arglist (arglist-from-form-spec (ensure-list operator) + :remove-args nil))) + (unless (eql arglist :not-available) + (values + (arglist.keyword-args arglist) + (arglist.allow-other-keys-p arglist))))) + +(defmethod extra-keywords (operator &rest args) + ;; default method + (declare (ignore args)) + (let ((symbol-function (symbol-function operator))) + (if (typep symbol-function 'generic-function) + (generic-function-keywords symbol-function) + nil))) + +(defun class-from-class-name-form (class-name-form) + (when (and (listp class-name-form) + (= (length class-name-form) 2) + (eq (car class-name-form) 'quote)) + (let* ((class-name (cadr class-name-form)) + (class (find-class class-name nil))) + (when (and class + (not (swank-mop:class-finalized-p class))) + ;; Try to finalize the class, which can fail if + ;; superclasses are not defined yet + (handler-case (swank-mop:finalize-inheritance class) + (program-error (c) + (declare (ignore c))))) + class))) + +(defun extra-keywords/slots (class) + (multiple-value-bind (slots allow-other-keys-p) + (if (swank-mop:class-finalized-p class) + (values (swank-mop:class-slots class) nil) + (values (swank-mop:class-direct-slots class) t)) + (let ((slot-init-keywords + (loop for slot in slots append + (mapcar (lambda (initarg) + (make-keyword-arg + initarg + (swank-mop:slot-definition-name slot) + (swank-mop:slot-definition-initform slot))) + (swank-mop:slot-definition-initargs slot))))) + (values slot-init-keywords allow-other-keys-p)))) + +(defun extra-keywords/make-instance (operator &rest args) + (declare (ignore operator)) + (unless (null args) + (let* ((class-name-form (car args)) + (class (class-from-class-name-form class-name-form))) + (when class + (multiple-value-bind (slot-init-keywords class-aokp) + (extra-keywords/slots class) + (multiple-value-bind (allocate-instance-keywords ai-aokp) + (applicable-methods-keywords + #'allocate-instance (list class)) + (multiple-value-bind (initialize-instance-keywords ii-aokp) + (applicable-methods-keywords + #'initialize-instance (list (swank-mop:class-prototype class))) + (multiple-value-bind (shared-initialize-keywords si-aokp) + (applicable-methods-keywords + #'shared-initialize (list (swank-mop:class-prototype class) t)) + (values (append slot-init-keywords + allocate-instance-keywords + initialize-instance-keywords + shared-initialize-keywords) + (or class-aokp ai-aokp ii-aokp si-aokp) + (list class-name-form)))))))))) + +(defun extra-keywords/change-class (operator &rest args) + (declare (ignore operator)) + (unless (null args) + (let* ((class-name-form (car args)) + (class (class-from-class-name-form class-name-form))) + (when class + (multiple-value-bind (slot-init-keywords class-aokp) + (extra-keywords/slots class) + (declare (ignore class-aokp)) + (multiple-value-bind (shared-initialize-keywords si-aokp) + (applicable-methods-keywords + #'shared-initialize (list (swank-mop:class-prototype class) t)) + ;; FIXME: much as it would be nice to include the + ;; applicable keywords from + ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see + ;; how to do it: so we punt, always declaring + ;; &ALLOW-OTHER-KEYS. + (declare (ignore si-aokp)) + (values (append slot-init-keywords shared-initialize-keywords) + t + (list class-name-form)))))))) + +(defmacro multiple-value-or (&rest forms) + (if (null forms) + nil + (let ((first (first forms)) + (rest (rest forms))) + `(let* ((values (multiple-value-list ,first)) + (primary-value (first values))) + (if primary-value + (values-list values) + (multiple-value-or ,@rest)))))) + +(defmethod extra-keywords ((operator (eql 'make-instance)) + &rest args) + (multiple-value-or (apply #'extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'make-condition)) + &rest args) + (multiple-value-or (apply #'extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'error)) + &rest args) + (multiple-value-or (apply #'extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'signal)) + &rest args) + (multiple-value-or (apply #'extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'warn)) + &rest args) + (multiple-value-or (apply #'extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'cerror)) + &rest args) + (multiple-value-bind (keywords aok determiners) + (apply #'extra-keywords/make-instance operator + (cdr args)) + (if keywords + (values keywords aok + (cons (car args) determiners)) + (call-next-method)))) + +(defmethod extra-keywords ((operator (eql 'change-class)) + &rest args) + (multiple-value-bind (keywords aok determiners) + (apply #'extra-keywords/change-class operator (cdr args)) + (if keywords + (values keywords aok + (cons (car args) determiners)) + (call-next-method)))) + +(defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords allow-other-keys-p) + "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P." + (when keywords + (setf (arglist.key-p decoded-arglist) t) + (setf (arglist.keyword-args decoded-arglist) + (remove-duplicates + (append (arglist.keyword-args decoded-arglist) + keywords) + :key #'keyword-arg.keyword))) + (setf (arglist.allow-other-keys-p decoded-arglist) + (or (arglist.allow-other-keys-p decoded-arglist) + allow-other-keys-p))) + +(defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form) + "Determine extra keywords from the function call FORM, and modify +DECODED-ARGLIST to include them. As a secondary return value, return +the initial sublist of ARGS that was needed to determine the extra +keywords. As a tertiary return value, return whether any enrichment +was done." + (multiple-value-bind (extra-keywords extra-aok determining-args) + (apply #'extra-keywords form) + ;; enrich the list of keywords with the extra keywords + (enrich-decoded-arglist-with-keywords decoded-arglist + extra-keywords extra-aok) + (values decoded-arglist + determining-args + (or extra-keywords extra-aok)))) + +(defgeneric compute-enriched-decoded-arglist (operator-form argument-forms) + (:documentation + "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and +ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords. +If the arglist is not available, return :NOT-AVAILABLE.")) + +(defmethod compute-enriched-decoded-arglist (operator-form argument-forms) + (let ((arglist (arglist operator-form))) + (etypecase arglist + ((member :not-available) + :not-available) + (list + (let ((decoded-arglist (decode-arglist arglist))) + (enrich-decoded-arglist-with-extra-keywords decoded-arglist + (cons operator-form + argument-forms))))))) + +(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'with-open-file)) + argument-forms) + (declare (ignore argument-forms)) + (multiple-value-bind (decoded-arglist determining-args) + (call-next-method) + (let ((first-arg (first (arglist.required-args decoded-arglist))) + (open-arglist (compute-enriched-decoded-arglist 'open nil))) + (when (and (arglist-p first-arg) (arglist-p open-arglist)) + (enrich-decoded-arglist-with-keywords + first-arg + (arglist.keyword-args open-arglist) + nil))) + (values decoded-arglist determining-args t))) + +(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply)) + argument-forms) + (let ((function-name-form (car argument-forms))) + (when (and (listp function-name-form) + (length= function-name-form 2) + (member (car function-name-form) '(quote function))) + (let ((function-name (cadr function-name-form))) + (when (valid-operator-symbol-p function-name) + (let ((function-arglist + (compute-enriched-decoded-arglist function-name + (cdr argument-forms)))) + (return-from compute-enriched-decoded-arglist + (values (make-arglist :required-args + (list 'function) + :optional-args + (append + (mapcar #'(lambda (arg) + (make-optional-arg arg nil)) + (arglist.required-args function-arglist)) + (arglist.optional-args function-arglist)) + :key-p + (arglist.key-p function-arglist) + :keyword-args + (arglist.keyword-args function-arglist) + :rest + 'args + :allow-other-keys-p + (arglist.allow-other-keys-p function-arglist)) + (list function-name-form) + t))))))) + (call-next-method)) + +(defvar *remove-keywords-alist* + '((:test :test-not) + (:test-not :test))) + +(defun remove-actual-args (decoded-arglist actual-arglist) + "Remove from DECODED-ARGLIST the arguments that have already been +provided in ACTUAL-ARGLIST." + (assert (or (and (not (arglist.key-p decoded-arglist)) + (not (arglist.any-p decoded-arglist))) + (exactly-one-p (arglist.key-p decoded-arglist) + (arglist.any-p decoded-arglist)))) + (loop while (and actual-arglist + (arglist.required-args decoded-arglist)) + do (progn (pop actual-arglist) + (pop (arglist.required-args decoded-arglist)))) + (loop while (and actual-arglist + (arglist.optional-args decoded-arglist)) + do (progn (pop actual-arglist) + (pop (arglist.optional-args decoded-arglist)))) + (if (arglist.any-p decoded-arglist) + (remove-&any-args decoded-arglist actual-arglist) + (remove-&key-args decoded-arglist actual-arglist)) + decoded-arglist) + +(defun remove-&key-args (decoded-arglist key-args) + (loop for keyword in key-args by #'cddr + for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*)) + do (setf (arglist.keyword-args decoded-arglist) + (remove-if (lambda (kw) + (or (eql kw keyword) + (member kw keywords-to-remove))) + (arglist.keyword-args decoded-arglist) + :key #'keyword-arg.keyword))) ) + +(defun remove-&any-args (decoded-arglist any-args) + (setf (arglist.any-args decoded-arglist) + (remove-if #'(lambda (x) (member x any-args)) + (arglist.any-args decoded-arglist) + :key #'(lambda (x) (first (ensure-list x)))))) + + +(defun arglist-from-form-spec (form-spec &key (remove-args t)) + "Returns the decoded arglist that corresponds to FORM-SPEC. If +REMOVE-ARGS is T, the arguments that are contained in FORM-SPEC +are removed from the result arglist. + +Examples: + + (arglist-from-form-spec '(defun)) + + ~=> (name args &body body) + + (arglist-from-form-spec '(defun foo)) + + ~=> (args &body body) + + (arglist-from-form-spec '(defun foo) :remove-args nil)) + + ~=> (name args &body body)) + + (arglist-from-form-spec '((:type-specifier float) 42) :remove-args nil) + + ~=> (&optional lower-limit upper-limit) +" + (if (null form-spec) + :not-available + (multiple-value-bind (type operator arguments) + (split-form-spec form-spec) + (arglist-dispatch type operator arguments :remove-args remove-args)))) + + +(defmacro with-availability ((var) form &body body) + `(let ((,var ,form)) + (if (eql ,var :not-available) + :not-available + (progn ,@body)))) + +(defgeneric arglist-dispatch (operator-type operator arguments &key remove-args)) + +(defmethod arglist-dispatch (operator-type operator arguments &key (remove-args t)) + (when (and (symbolp operator) + (valid-operator-symbol-p operator)) + (multiple-value-bind (decoded-arglist determining-args any-enrichment) + (compute-enriched-decoded-arglist operator arguments) + (etypecase decoded-arglist + ((member :not-available) + :not-available) + (arglist + (cond + (remove-args + ;; get rid of formal args already provided + (remove-actual-args decoded-arglist arguments)) + (t + ;; replace some formal args by determining actual args + (remove-actual-args decoded-arglist determining-args) + (setf (arglist.provided-args decoded-arglist) + determining-args))) + (return-from arglist-dispatch + (values decoded-arglist any-enrichment)))))) + :not-available) + +(defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'defmethod)) + arguments &key (remove-args t)) + (when (and (listp arguments) + (not (null arguments)) ;have generic function name + (notany #'listp (rest arguments))) ;don't have arglist yet + (let* ((gf-name (first arguments)) + (gf (and (or (symbolp gf-name) + (and (listp gf-name) + (eql (first gf-name) 'setf))) + (fboundp gf-name) + (fdefinition gf-name)))) + (when (typep gf 'generic-function) + (with-availability (arglist) (arglist gf) + (return-from arglist-dispatch + (values (make-arglist :provided-args (if remove-args + nil + (list gf-name)) + :required-args (list arglist) + :rest "body" :body-p t) + t)))))) + (call-next-method)) + +(defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'eval-when)) + arguments &key (remove-args t)) + (let ((eval-when-args '(:compile-toplevel :load-toplevel :execute))) + (make-arglist :required-args (list (maybecall remove-args #'remove-actual-args + (make-arglist :any-args eval-when-args) + arguments)) + :rest '#:body :body-p t))) + +(defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'declare)) + arguments &key (remove-args t)) + ;; Catching 'DECLARE before SWANK-BACKEND:ARGLIST can barf. + (declare (ignore remove-args)) + (make-arglist :rest '#:decl-specifiers)) + +(defmethod arglist-dispatch ((operator-type (eql :declaration)) + decl-identifier decl-args &key (remove-args t)) + (with-availability (arglist) + (declaration-arglist decl-identifier) + (maybecall remove-args #'remove-actual-args + (decode-arglist arglist) decl-args)) + ;; We don't fall back to CALL-NEXT-METHOD because we're within a + ;; different namespace! + ) + +(defmethod arglist-dispatch ((operator-type (eql :type-specifier)) + type-specifier specifier-args &key (remove-args t)) + (with-availability (arglist) + (type-specifier-arglist type-specifier) + (maybecall remove-args #'remove-actual-args + (decode-arglist arglist) specifier-args)) + ;; No CALL-NEXT-METHOD, see above. + ) + + +(defun read-incomplete-form-from-string (form-string) + (with-buffer-syntax () + (call-with-ignored-reader-errors + #'(lambda () + (read-from-string form-string))))) + +(defun call-with-ignored-reader-errors (thunk) + (declare (type (function () (values &rest t)) thunk)) + (declare (optimize (speed 3) (safety 1))) + (handler-case (funcall thunk) + (reader-error (c) + (declare (ignore c)) + nil) + (stream-error (c) + (declare (ignore c)) + nil))) + +(defslimefun complete-form (form-string) + "Read FORM-STRING in the current buffer package, then complete it +by adding a template for the missing arguments." + (multiple-value-bind (form newly-interned-symbols) + (parse-form-spec form-string) + (unwind-protect + (when (consp form) + (let ((form-completion (arglist-from-form-spec form))) + (unless (eql form-completion :not-available) + (return-from complete-form + (decoded-arglist-to-template-string form-completion + *buffer-package* + :prefix ""))))) + (mapc #'unintern-in-home-package newly-interned-symbols)) + :not-available)) + + +(defun arglist-ref (decoded-arglist operator &rest indices) + (cond + ((null indices) decoded-arglist) + ((not (arglist-p decoded-arglist)) nil) + (t + (let ((index (first indices)) + (args (append (and operator + (list operator)) + (arglist.required-args decoded-arglist) + (arglist.optional-args decoded-arglist)))) + (when (< index (length args)) + (let ((arg (elt args index))) + (apply #'arglist-ref arg nil (rest indices)))))))) + +(defslimefun completions-for-keyword (raw-specs keyword-string arg-index-specs) + (with-buffer-syntax () + (multiple-value-bind (form-spec position newly-interned-symbols) + (parse-first-valid-form-spec raw-specs) + (unwind-protect + (when form-spec + (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) + (unless (eql arglist :not-available) + (let* ((operator (nth-value 1 (split-form-spec form-spec))) + (indices (reverse (rest (subseq arg-index-specs 0 (1+ position))))) + (arglist (apply #'arglist-ref arglist operator indices))) + (when (and arglist (arglist-p arglist)) + ;; It would be possible to complete keywords only if we + ;; are in a keyword position, but it is not clear if we + ;; want that. + (let* ((keywords + (append (mapcar #'keyword-arg.keyword + (arglist.keyword-args arglist)) + (remove-if-not #'keywordp (arglist.any-args arglist)))) + (keyword-name + (tokenize-symbol keyword-string)) + (matching-keywords + (find-matching-symbols-in-list keyword-name keywords + #'compound-prefix-match)) + (converter (completion-output-symbol-converter keyword-string)) + (strings + (mapcar converter + (mapcar #'symbol-name matching-keywords))) + (completion-set + (format-completion-set strings nil ""))) + (list completion-set + (longest-compound-prefix completion-set)))))))) + (mapc #'unintern-in-home-package newly-interned-symbols))))) + + +(defun arglist-to-string (arglist package &key print-right-margin highlight) + (decoded-arglist-to-string (decode-arglist arglist) + :package package + :print-right-margin print-right-margin + :highlight highlight)) + +(defun test-print-arglist () + (flet ((test (list string) + (let* ((p (find-package :swank)) + (actual (arglist-to-string list p))) + (unless (string= actual string) + (warn "Test failed: ~S => ~S~% Expected: ~S" + list actual string))))) + (test '(function cons) "(function cons)") + (test '(quote cons) "(quote cons)") + (test '(&key (function #'+)) "(&key (function #'+))") + (test '(&whole x y z) "(y z)") + (test '(x &aux y z) "(x)") + (test '(x &environment env y) "(x y)") + (test '(&key ((function f))) "(&key ((function f)))") + (test '(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body) + "(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)") + (test '(declare (optimize &any (speed 1) (safety 1))) + "(declare (optimize &any (speed 1) (safety 1)))") + )) + +(test-print-arglist) + +(provide :swank-arglists) Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-asdf.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-asdf.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-asdf.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,63 @@ +;;; swank-asdf.el -- ASDF support +;; +;; Authors: Daniel Barlow <dan(a)telent.net> +;; Marco Baringer <mb(a)bese.it> +;; Edi Weitz <edi(a)agharta.de> +;; and others +;; License: Public Domain +;; + +(in-package :swank) + +(defslimefun operate-on-system-for-emacs (system-name operation &rest keywords) + "Compile and load SYSTEM using ASDF. +Record compiler notes signalled as `compiler-condition's." + (swank-compiler + (lambda () + (apply #'operate-on-system system-name operation keywords)))) + +(defun operate-on-system (system-name operation-name &rest keyword-args) + "Perform OPERATION-NAME on SYSTEM-NAME using ASDF. +The KEYWORD-ARGS are passed on to the operation. +Example: +\(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)" + (with-compilation-hooks () + (let ((operation (find-symbol operation-name :asdf))) + (when (null operation) + (error "Couldn't find ASDF operation ~S" operation-name)) + (apply #'asdf:operate operation system-name keyword-args)))) + +(defun asdf-central-registry () + asdf:*central-registry*) + +(defslimefun list-all-systems-in-central-registry () + "Returns a list of all systems in ASDF's central registry." + (mapcar #'pathname-name + (delete-duplicates + (loop for dir in (asdf-central-registry) + for defaults = (eval dir) + when defaults + nconc (mapcar #'file-namestring + (directory + (make-pathname :defaults defaults + :version :newest + :type "asd" + :name :wild + :case :local)))) + :test #'string=))) + +(defslimefun list-all-systems-known-to-asdf () + "Returns a list of all systems ASDF knows already." + ;; ugh, yeah, it's unexported - but do we really expect this to + ;; change anytime soon? + (loop for name being the hash-keys of asdf::*defined-systems* + collect name)) + +(defslimefun list-asdf-systems () + "Returns the systems in ASDF's central registry and those which ASDF +already knows." + (nunion (list-all-systems-known-to-asdf) + (list-all-systems-in-central-registry) + :test #'string=)) + +(provide :swank-asdf) Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-c-p-c.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-c-p-c.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-c-p-c.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,279 @@ +;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion +;; +;; Author: Luke Gorrie <luke(a)synap.se> +;; Edi Weitz <edi(a)agharta.de> +;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> +;; Tobias C. Rittweiler <tcr(a)freebits.de> +;; and others +;; +;; License: Public Domain +;; + + +(in-package :swank) + +(defslimefun completions (string default-package-name) + "Return a list of completions for a symbol designator STRING. + +The result is the list (COMPLETION-SET COMPLETED-PREFIX), where +COMPLETION-SET is the list of all matching completions, and +COMPLETED-PREFIX is the best (partial) completion of the input +string. + +Simple compound matching is supported on a per-hyphen basis: + + (completions \"m-v-\" \"COMMON-LISP\") + ==> ((\"multiple-value-bind\" \"multiple-value-call\" + \"multiple-value-list\" \"multiple-value-prog1\" + \"multiple-value-setq\" \"multiple-values-limit\") + \"multiple-value\") + +\(For more advanced compound matching, see FUZZY-COMPLETIONS.) + +If STRING is package qualified the result list will also be +qualified. If string is non-qualified the result strings are +also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. + +The way symbols are matched depends on the symbol designator's +format. The cases are as follows: + FOO - Symbols with matching prefix and accessible in the buffer package. + PKG:FOO - Symbols with matching prefix and external in package PKG. + PKG::FOO - Symbols with matching prefix and accessible in package PKG. +" + (let ((completion-set (completion-set string default-package-name + #'compound-prefix-match))) + (when completion-set + (list completion-set (longest-compound-prefix completion-set))))) + +;;;;; Find completion set + +(defun completion-set (string default-package-name matchp) + "Return the set of completion-candidates as strings." + (multiple-value-bind (name package-name package internal-p) + (parse-completion-arguments string default-package-name) + (let* ((symbols (mapcar (completion-output-symbol-converter name) + (and package + (mapcar #'symbol-name + (find-matching-symbols name + package + (and (not internal-p) + package-name) + matchp))))) + (packs (mapcar (completion-output-package-converter name) + (and (not package-name) + (find-matching-packages name matchp))))) + (format-completion-set (nconc symbols packs) internal-p package-name)))) + +(defun find-matching-symbols (string package external test) + "Return a list of symbols in PACKAGE matching STRING. +TEST is called with two strings. If EXTERNAL is true, only external +symbols are returned." + (let ((completions '()) + (converter (completion-output-symbol-converter string))) + (flet ((symbol-matches-p (symbol) + (and (or (not external) + (symbol-external-p symbol package)) + (funcall test string + (funcall converter (symbol-name symbol)))))) + (do-symbols* (symbol package) + (when (symbol-matches-p symbol) + (push symbol completions)))) + completions)) + +(defun find-matching-symbols-in-list (string list test) + "Return a list of symbols in LIST matching STRING. +TEST is called with two strings." + (let ((completions '()) + (converter (completion-output-symbol-converter string))) + (flet ((symbol-matches-p (symbol) + (funcall test string + (funcall converter (symbol-name symbol))))) + (dolist (symbol list) + (when (symbol-matches-p symbol) + (push symbol completions)))) + (remove-duplicates completions))) + +(defun find-matching-packages (name matcher) + "Return a list of package names matching NAME with MATCHER. +MATCHER is a two-argument predicate." + (let ((to-match (string-upcase name))) + (remove-if-not (lambda (x) (funcall matcher to-match x)) + (mapcar (lambda (pkgname) + (concatenate 'string pkgname ":")) + (loop for package in (list-all-packages) + collect (package-name package) + append (package-nicknames package)))))) + + +;; PARSE-COMPLETION-ARGUMENTS return table: +;; +;; user behaviour | NAME | PACKAGE-NAME | PACKAGE +;; ----------------+--------+--------------+----------------------------------- +;; asdf [tab] | "asdf" | NIL | #<PACKAGE "DEFAULT-PACKAGE-NAME"> +;; | | | or *BUFFER-PACKAGE* +;; asdf: [tab] | "" | "asdf" | #<PACKAGE "ASDF"> +;; | | | +;; asdf:foo [tab] | "foo" | "asdf" | #<PACKAGE "ASDF"> +;; | | | +;; as:fo [tab] | "fo" | "as" | NIL +;; | | | +;; : [tab] | "" | "" | #<PACKAGE "KEYWORD"> +;; | | | +;; :foo [tab] | "foo" | "" | #<PACKAGE "KEYWORD"> +;; +(defun parse-completion-arguments (string default-package-name) + "Parse STRING as a symbol designator. +Return these values: + SYMBOL-NAME + PACKAGE-NAME, or nil if the designator does not include an explicit package. + PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is + NIL, return the respective package of DEFAULT-PACKAGE-NAME instead; + if PACKAGE is non-NIL but a package cannot be found under that name, + return NIL.) + INTERNAL-P, if the symbol is qualified with `::'." + (multiple-value-bind (name package-name internal-p) + (tokenize-symbol string) + (if package-name + (let ((package (guess-package (if (equal package-name "") + "KEYWORD" + package-name)))) + (values name package-name package internal-p)) + (let ((package (guess-package default-package-name))) + (values name package-name (or package *buffer-package*) internal-p)) + ))) + + + +(defun completion-output-case-converter (input &optional with-escaping-p) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case." + (ecase (readtable-case *readtable*) + (:upcase (cond ((or with-escaping-p + (not (some #'lower-case-p input))) + #'identity) + (t #'string-downcase))) + (:invert (lambda (output) + (multiple-value-bind (lower upper) (determine-case output) + (cond ((and lower upper) output) + (lower (string-upcase output)) + (upper (string-downcase output)) + (t output))))) + (:downcase (cond ((or with-escaping-p + (not (some #'upper-case-p input))) + #'identity) + (t #'string-upcase))) + (:preserve #'identity))) + +(defun completion-output-package-converter (input) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case." + (completion-output-case-converter input)) + +(defun completion-output-symbol-converter (input) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case. Escape symbols when needed." + (let ((case-converter (completion-output-case-converter input)) + (case-converter-with-escaping (completion-output-case-converter input t))) + (lambda (str) + (if (or (multiple-value-bind (lowercase uppercase) + (determine-case str) + ;; In these readtable cases, symbols with letters from + ;; the wrong case need escaping + (case (readtable-case *readtable*) + (:upcase lowercase) + (:downcase uppercase) + (t nil))) + (some (lambda (el) + (or (member el '(#\: #\Space #\Newline #\Tab)) + (multiple-value-bind (macrofun nonterminating) + (get-macro-character el) + (and macrofun + (not nonterminating))))) + str)) + (concatenate 'string "|" (funcall case-converter-with-escaping str) "|") + (funcall case-converter str))))) + + +(defun determine-case (string) + "Return two booleans LOWER and UPPER indicating whether STRING +contains lower or upper case characters." + (values (some #'lower-case-p string) + (some #'upper-case-p string))) + + +;;;;; Compound-prefix matching + +(defun make-compound-prefix-matcher (delimeter &key (test #'char=)) + "Returns a matching function that takes a `prefix' and a +`target' string and which returns T if `prefix' is a +compound-prefix of `target', and otherwise NIL. + +Viewing each of `prefix' and `target' as a series of substrings +delimited by DELIMETER, if each substring of `prefix' is a prefix +of the corresponding substring in `target' then we call `prefix' +a compound-prefix of `target'." + (lambda (prefix target) + (declare (type simple-string prefix target)) + (loop for ch across prefix + with tpos = 0 + always (and (< tpos (length target)) + (if (char= ch delimeter) + (setf tpos (position #\- target :start tpos)) + (funcall test ch (aref target tpos)))) + do (incf tpos)))) + +(defun compound-prefix-match (prefix target) + "Examples: +\(compound-prefix-match \"foo\" \"foobar\") => t +\(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t +\(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL +" + (funcall (make-compound-prefix-matcher #\-) prefix target)) + + +;;;;; Extending the input string by completion + +(defun longest-compound-prefix (completions &optional (delimeter #\-)) + "Return the longest compound _prefix_ for all COMPLETIONS." + (flet ((tokenizer (string) (tokenize-completion string delimeter))) + (untokenize-completion + (loop for token-list in (transpose-lists (mapcar #'tokenizer completions)) + if (notevery #'string= token-list (rest token-list)) + collect (longest-common-prefix token-list) ; Note that we possibly collect + and do (loop-finish) ; the "" here as well, so that + else collect (first token-list))))) ; UNTOKENIZE-COMPLETION will + ; append a hyphen for us. +(defun tokenize-completion (string delimeter) + "Return all substrings of STRING delimited by DELIMETER." + (loop with end + for start = 0 then (1+ end) + until (> start (length string)) + do (setq end (or (position delimeter string :start start) (length string))) + collect (subseq string start end))) + +(defun untokenize-completion (tokens) + (format nil "~{~A~^-~}" tokens)) + +(defun transpose-lists (lists) + "Turn a list-of-lists on its side. +If the rows are of unequal length, truncate uniformly to the shortest. + +For example: +\(transpose-lists '((ONE TWO THREE) (1 2))) + => ((ONE 1) (TWO 2))" + (cond ((null lists) '()) + ((some #'null lists) '()) + (t (cons (mapcar #'car lists) + (transpose-lists (mapcar #'cdr lists)))))) + + +;;;; Completion for character names + +(defslimefun completions-for-character (prefix) + (let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal)) + (completion-set (character-completion-set prefix matcher)) + (completions (sort completion-set #'string<))) + (list completions (longest-compound-prefix completions #\_)))) + +(provide :swank-c-p-c) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,737 @@ +;;; swank-fancy-inspector.lisp --- Fancy inspector for CLOS objects +;; +;; Author: Marco Baringer <mb(a)bese.it> and others +;; License: Public Domain +;; + +(in-package :swank) + +;; Subclass `backend-inspector' so that backend specific methods are +;; also considered. +(defclass fancy-inspector (backend-inspector) ()) + +(defmethod inspect-for-emacs ((symbol symbol) (inspector fancy-inspector)) + (declare (ignore inspector)) + (let ((package (symbol-package symbol))) + (multiple-value-bind (_symbol status) + (and package (find-symbol (string symbol) package)) + (declare (ignore _symbol)) + (values + "A symbol." + (append + (label-value-line "Its name is" (symbol-name symbol)) + ;; + ;; Value + (cond ((boundp symbol) + (label-value-line (if (constantp symbol) + "It is a constant of value" + "It is a global variable bound to") + (symbol-value symbol))) + (t '("It is unbound." (:newline)))) + (docstring-ispec "Documentation" symbol 'variable) + (multiple-value-bind (expansion definedp) (macroexpand symbol) + (if definedp + (label-value-line "It is a symbol macro with expansion" + expansion))) + ;; + ;; Function + (if (fboundp symbol) + (append (if (macro-function symbol) + `("It a macro with macro-function: " + (:value ,(macro-function symbol))) + `("It is a function: " + (:value ,(symbol-function symbol)))) + `(" " (:action "[make funbound]" + ,(lambda () (fmakunbound symbol)))) + `((:newline))) + `("It has no function value." (:newline))) + (docstring-ispec "Function Documentation" symbol 'function) + (if (compiler-macro-function symbol) + (label-value-line "It also names the compiler macro" + (compiler-macro-function symbol))) + (docstring-ispec "Compiler Macro Documentation" + symbol 'compiler-macro) + ;; + ;; Package + (if package + `("It is " ,(string-downcase (string status)) + " to the package: " + (:value ,package ,(package-name package)) + ,@(if (eq :internal status) + `(" " + (:action "[export it]" + ,(lambda () (export symbol package))))) + " " + (:action "[unintern it]" + ,(lambda () (unintern symbol package))) + (:newline)) + '("It is a non-interned symbol." (:newline))) + ;; + ;; Plist + (label-value-line "Property list" (symbol-plist symbol)) + ;; + ;; Class + (if (find-class symbol nil) + `("It names the class " + (:value ,(find-class symbol) ,(string symbol)) + " " + (:action "[remove]" + ,(lambda () (setf (find-class symbol) nil))) + (:newline))) + ;; + ;; More package + (if (find-package symbol) + (label-value-line "It names the package" (find-package symbol))) + ))))) + +(defun docstring-ispec (label object kind) + "Return a inspector spec if OBJECT has a docstring of of kind KIND." + (let ((docstring (documentation object kind))) + (cond ((not docstring) nil) + ((< (+ (length label) (length docstring)) + 75) + (list label ": " docstring '(:newline))) + (t + (list label ": " '(:newline) " " docstring '(:newline)))))) + +(defmethod inspect-for-emacs ((f function) (inspector fancy-inspector)) + (declare (ignore inspector)) + (values "A function." + (append + (label-value-line "Name" (function-name f)) + `("Its argument list is: " + ,(inspector-princ (arglist f)) (:newline)) + (docstring-ispec "Documentation" f t) + (if (function-lambda-expression f) + (label-value-line "Lambda Expression" + (function-lambda-expression f)))))) + +(defun method-specializers-for-inspect (method) + "Return a \"pretty\" list of the method's specializers. Normal + specializers are replaced by the name of the class, eql + specializers are replaced by `(eql ,object)." + (mapcar (lambda (spec) + (typecase spec + (swank-mop:eql-specializer + `(eql ,(swank-mop:eql-specializer-object spec))) + (t (swank-mop:class-name spec)))) + (swank-mop:method-specializers method))) + +(defun method-for-inspect-value (method) + "Returns a \"pretty\" list describing METHOD. The first element + of the list is the name of generic-function method is + specialiazed on, the second element is the method qualifiers, + the rest of the list is the method's specialiazers (as per + method-specializers-for-inspect)." + (append (list (swank-mop:generic-function-name + (swank-mop:method-generic-function method))) + (swank-mop:method-qualifiers method) + (method-specializers-for-inspect method))) + +(defmethod inspect-for-emacs ((object standard-object) + (inspector fancy-inspector)) + (let ((class (class-of object))) + (values "An object." + `("Class: " (:value ,class) (:newline) + ,@(all-slots-for-inspector object inspector))))) + +(defvar *gf-method-getter* 'methods-by-applicability + "This function is called to get the methods of a generic function. +The default returns the method sorted by applicability. +See `methods-by-applicability'.") + +(defun specializer< (specializer1 specializer2) + "Return true if SPECIALIZER1 is more specific than SPECIALIZER2." + (let ((s1 specializer1) (s2 specializer2) ) + (cond ((typep s1 'swank-mop:eql-specializer) + (not (typep s2 'swank-mop:eql-specializer))) + (t + (flet ((cpl (class) + (and (swank-mop:class-finalized-p class) + (swank-mop:class-precedence-list class)))) + (member s2 (cpl s1))))))) + +(defun methods-by-applicability (gf) + "Return methods ordered by most specific argument types. + +`method-specializer<' is used for sorting." + ;; FIXME: argument-precedence-order and qualifiers are ignored. + (labels ((method< (meth1 meth2) + (loop for s1 in (swank-mop:method-specializers meth1) + for s2 in (swank-mop:method-specializers meth2) + do (cond ((specializer< s2 s1) (return nil)) + ((specializer< s1 s2) (return t)))))) + (stable-sort (copy-seq (swank-mop:generic-function-methods gf)) #'method<))) + +(defun abbrev-doc (doc &optional (maxlen 80)) + "Return the first sentence of DOC, but not more than MAXLAN characters." + (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen))) + maxlen + (length doc)))) + +(defgeneric inspect-slot-for-emacs (class object slot) + (:method (class object slot) + (let ((slot-name (swank-mop:slot-definition-name slot)) + (boundp (swank-mop:slot-boundp-using-class class object slot))) + `(,@(if boundp + `((:value ,(swank-mop:slot-value-using-class class object slot))) + `("#<unbound>")) + " " + (:action "[set value]" + ,(lambda () (with-simple-restart + (abort "Abort setting slot ~S" slot-name) + (let ((value-string (eval-in-emacs + `(condition-case c + (slime-read-object + ,(format nil "Set slot ~S to (evaluated) : " slot-name)) + (quit nil))))) + (when (and value-string + (not (string= value-string ""))) + (setf (swank-mop:slot-value-using-class class object slot) + (eval (read-from-string value-string)))))))) + ,@(when boundp + `(" " (:action "[make unbound]" + ,(lambda () (swank-mop:slot-makunbound-using-class class object slot))))))))) + +(defgeneric all-slots-for-inspector (object inspector) + (:method ((object standard-object) inspector) + (declare (ignore inspector)) + (append '("--------------------" (:newline) + "All Slots:" (:newline)) + (let* ((class (class-of object)) + (direct-slots (swank-mop:class-direct-slots class)) + (effective-slots (sort (copy-seq (swank-mop:class-slots class)) + #'string< :key #'swank-mop:slot-definition-name)) + (slot-presentations (loop for effective-slot :in effective-slots + collect (inspect-slot-for-emacs + class object effective-slot))) + (longest-slot-name-length + (loop for slot :in effective-slots + maximize (length (symbol-name + (swank-mop:slot-definition-name slot)))))) + (loop + for effective-slot :in effective-slots + for slot-presentation :in slot-presentations + for direct-slot = (find (swank-mop:slot-definition-name effective-slot) + direct-slots :key #'swank-mop:slot-definition-name) + for slot-name = (inspector-princ + (swank-mop:slot-definition-name effective-slot)) + for padding-length = (- longest-slot-name-length + (length (symbol-name + (swank-mop:slot-definition-name + effective-slot)))) + collect `(:value ,(if direct-slot + (list direct-slot effective-slot) + effective-slot) + ,slot-name) + collect (make-array padding-length + :element-type 'character + :initial-element #\Space) + collect " = " + append slot-presentation + collect '(:newline)))))) + +(defmethod inspect-for-emacs ((gf standard-generic-function) + (inspector fancy-inspector)) + (flet ((lv (label value) (label-value-line label value))) + (values + "A generic function." + (append + (lv "Name" (swank-mop:generic-function-name gf)) + (lv "Arguments" (swank-mop:generic-function-lambda-list gf)) + (docstring-ispec "Documentation" gf t) + (lv "Method class" (swank-mop:generic-function-method-class gf)) + (lv "Method combination" + (swank-mop:generic-function-method-combination gf)) + `("Methods: " (:newline)) + (loop for method in (funcall *gf-method-getter* gf) append + `((:value ,method ,(inspector-princ + ;; drop the name of the GF + (cdr (method-for-inspect-value method)))) + " " + (:action "[remove method]" + ,(let ((m method)) ; LOOP reassigns method + (lambda () + (remove-method gf m)))) + (:newline))) + `((:newline)) + (all-slots-for-inspector gf inspector))))) + +(defmethod inspect-for-emacs ((method standard-method) + (inspector fancy-inspector)) + (values "A method." + `("Method defined on the generic function " + (:value ,(swank-mop:method-generic-function method) + ,(inspector-princ + (swank-mop:generic-function-name + (swank-mop:method-generic-function method)))) + (:newline) + ,@(docstring-ispec "Documentation" method t) + "Lambda List: " (:value ,(swank-mop:method-lambda-list method)) + (:newline) + "Specializers: " (:value ,(swank-mop:method-specializers method) + ,(inspector-princ (method-specializers-for-inspect method))) + (:newline) + "Qualifiers: " (:value ,(swank-mop:method-qualifiers method)) + (:newline) + "Method function: " (:value ,(swank-mop:method-function method)) + (:newline) + ,@(all-slots-for-inspector method inspector)))) + +(defmethod inspect-for-emacs ((class standard-class) + (inspector fancy-inspector)) + (values "A class." + `("Name: " (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(common-seperated-spec (swank-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(common-seperated-spec + (swank-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (swank-mop:class-finalized-p class) + (common-seperated-spec + (swank-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ + (swank-mop:slot-definition-name slot))))) + '("#<N/A (class not finalized)>")) + (:newline) + ,@(let ((doc (documentation class t))) + (when doc + `("Documentation:" (:newline) ,(inspector-princ doc) (:newline)))) + "Sub classes: " + ,@(common-seperated-spec (swank-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub ,(inspector-princ (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (swank-mop:class-finalized-p class) + (common-seperated-spec (swank-mop:class-precedence-list class) + (lambda (class) + `(:value ,class ,(inspector-princ (class-name class))))) + '("#<N/A (class not finalized)>")) + (:newline) + ,@(when (swank-mop:specializer-direct-methods class) + `("It is used as a direct specializer in the following methods:" (:newline) + ,@(loop + for method in (sort (copy-seq (swank-mop:specializer-direct-methods class)) + #'string< :key (lambda (x) + (symbol-name + (let ((name (swank-mop::generic-function-name + (swank-mop::method-generic-function x)))) + (if (symbolp name) name (second name)))))) + collect " " + collect `(:value ,method ,(inspector-princ (method-for-inspect-value method))) + collect '(:newline) + if (documentation method t) + collect " Documentation: " and + collect (abbrev-doc (documentation method t)) and + collect '(:newline)))) + "Prototype: " ,(if (swank-mop:class-finalized-p class) + `(:value ,(swank-mop:class-prototype class)) + '"#<N/A (class not finalized)>") + (:newline) + ,@(all-slots-for-inspector class inspector)))) + +(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) + (inspector fancy-inspector)) + (values "A slot." + `("Name: " (:value ,(swank-mop:slot-definition-name slot)) + (:newline) + ,@(when (swank-mop:slot-definition-documentation slot) + `("Documentation:" (:newline) + (:value ,(swank-mop:slot-definition-documentation slot)) + (:newline))) + "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline) + "Init form: " ,(if (swank-mop:slot-definition-initfunction slot) + `(:value ,(swank-mop:slot-definition-initform slot)) + "#<unspecified>") (:newline) + "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) + (:newline) + ,@(all-slots-for-inspector slot inspector)))) + + +;; Wrapper structure over the list of symbols of a package that should +;; be displayed with their respective classification flags. This is +;; because we need a unique type to dispatch on in INSPECT-FOR-EMACS. +;; Used by the Inspector for packages. +(defstruct (%package-symbols-container (:conc-name %container.) + (:constructor %%make-package-symbols-container)) + title ;; A string; the title of the inspector page in Emacs. + description ;; A list of renderable objects; used as description. + symbols ;; A list of symbols. Supposed to be sorted alphabetically. + grouping-kind ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING. + ) + +(defun %make-package-symbols-container (&key title description symbols) + (%%make-package-symbols-container :title title :description description + :symbols symbols :grouping-kind :symbol)) + +(defgeneric make-symbols-listing (grouping-kind symbols)) + +(defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols) + "Returns an object renderable by Emacs' inspector side that +alphabetically lists all the symbols in SYMBOLS together with a +concise string representation of what each symbol +represents (cf. CLASSIFY-SYMBOL & Fuzzy Completion.)" + (let ((max-length (loop for s in symbols maximizing (length (symbol-name s)))) + (distance 10)) ; empty distance between name and classification + (flet ((string-representations (symbol) + (let* ((name (symbol-name symbol)) + (length (length name)) + (padding (- max-length length)) + (classification (classify-symbol symbol))) + (values + (concatenate 'string + name + (make-string (+ padding distance) :initial-element #\Space)) + (symbol-classification->string classification))))) + `("" ; 8 is (length "Symbols:") + "Symbols:" ,(make-string (+ -8 max-length distance) :initial-element #\Space) "Flags:" + (:newline) + ,(concatenate 'string ; underlining dashes + (make-string (+ max-length distance -1) :initial-element #\-) + " " + (let* ((dummy (classify-symbol (gensym))) + (dummy (symbol-classification->string dummy)) + (classification-length (length dummy))) + (make-string classification-length :initial-element #\-))) + (:newline) + ,@(loop for symbol in symbols appending + (multiple-value-bind (symbol-string classification-string) + (string-representations symbol) + `((:value ,symbol ,symbol-string) ,classification-string + (:newline) + ))))))) + +(defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols) + "For each possible classification (cf. CLASSIFY-SYMBOL), group +all the symbols in SYMBOLS to all of their respective +classifications. (If a symbol is, for instance, boundp and a +generic-function, it'll appear both below the BOUNDP group and +the GENERIC-FUNCTION group.) As macros and special-operators are +specified to be FBOUNDP, there is no general FBOUNDP group, +instead there are the three explicit FUNCTION, MACRO and +SPECIAL-OPERATOR groups." + (let ((table (make-hash-table :test #'eq))) + (flet ((maybe-convert-fboundps (classifications) + ;; Convert an :FBOUNDP in CLASSIFICATIONS to :FUNCTION if possible. + (if (and (member :fboundp classifications) + (not (member :macro classifications)) + (not (member :special-operator classifications))) + (substitute :function :fboundp classifications) + (remove :fboundp classifications)))) + (loop for symbol in symbols do + (loop for classification in (maybe-convert-fboundps (classify-symbol symbol)) + ;; SYMBOLS are supposed to be sorted alphabetically; + ;; this property is preserved here except for reversing. + do (push symbol (gethash classification table))))) + (let* ((classifications (loop for k being each hash-key in table collect k)) + (classifications (sort classifications #'string<))) + (loop for classification in classifications + for symbols = (gethash classification table) + appending`(,(symbol-name classification) + (:newline) + ,(make-string 64 :initial-element #\-) + (:newline) + ,@(mapcan #'(lambda (symbol) + (list `(:value ,symbol ,(symbol-name symbol)) '(:newline))) + (nreverse symbols)) ; restore alphabetic orderness. + (:newline) + ))))) + +(defmethod inspect-for-emacs ((%container %package-symbols-container) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (with-struct (%container. title description symbols grouping-kind) %container + (values title + `(,@description + (:newline) + " " ,(ecase grouping-kind + (:symbol + `(:action "[Group by classification]" + ,(lambda () (setf grouping-kind :classification)) + :refreshp t)) + (:classification + `(:action "[Group by symbol]" + ,(lambda () (setf grouping-kind :symbol)) + :refreshp t))) + (:newline) (:newline) + ,@(make-symbols-listing grouping-kind symbols))))) + + +(defmethod inspect-for-emacs ((package package) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (let ((package-name (package-name package)) + (package-nicknames (package-nicknames package)) + (package-use-list (package-use-list package)) + (package-used-by-list (package-used-by-list package)) + (shadowed-symbols (package-shadowing-symbols package)) + (present-symbols '()) (present-symbols-length 0) + (internal-symbols '()) (internal-symbols-length 0) + (external-symbols '()) (external-symbols-length 0)) + + (do-symbols* (sym package) + (let ((status (symbol-status sym package))) + (when (not (eq status :inherited)) + (push sym present-symbols) (incf present-symbols-length) + (if (eq status :internal) + (progn (push sym internal-symbols) (incf internal-symbols-length)) + (progn (push sym external-symbols) (incf external-symbols-length)))))) + + (setf package-nicknames (sort (copy-list package-nicknames) #'string<) + package-use-list (sort (copy-list package-use-list) #'string< :key #'package-name) + package-used-by-list (sort (copy-list package-used-by-list) #'string< :key #'package-name) + shadowed-symbols (sort (copy-list shadowed-symbols) #'string<)) + + (setf present-symbols (sort present-symbols #'string<) ; SORT + STRING-LESSP + internal-symbols (sort internal-symbols #'string<) ; conses on at least + external-symbols (sort external-symbols #'string<)) ; SBCL 0.9.18. + + + (values + "A package." + `("" ; dummy to preserve indentation. + "Name: " (:value ,package-name) (:newline) + + "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline) + + ,@(when (documentation package t) + `("Documentation:" (:newline) ,(documentation package t) (:newline))) + + "Use list: " ,@(common-seperated-spec + package-use-list + (lambda (package) + `(:value ,package ,(package-name package)))) + (:newline) + + "Used by list: " ,@(common-seperated-spec + package-used-by-list + (lambda (package) + `(:value ,package ,(package-name package)))) + (:newline) + + ,@ ; ,@(flet ((...)) ...) would break indentation in Emacs. + (flet ((display-link (type symbols length &key title description) + (if (null symbols) + (format nil "0 ~A symbols." type) + `(:value ,(%make-package-symbols-container :title title + :description description + :symbols symbols) + ,(format nil "~D ~A symbol~P." length type length))))) + + `(,(display-link "present" present-symbols present-symbols-length + :title (format nil "All present symbols of package \"~A\"" package-name) + :description + '("A symbol is considered present in a package if it's" (:newline) + "\"accessible in that package directly, rather than" (:newline) + "being inherited from another package.\"" (:newline) + "(CLHS glossary entry for `present')" (:newline))) + + (:newline) + ,(display-link "external" external-symbols external-symbols-length + :title (format nil "All external symbols of package \"~A\"" package-name) + :description + '("A symbol is considered external of a package if it's" (:newline) + "\"part of the `external interface' to the package and" (:newline) + "[is] inherited by any other package that uses the" (:newline) + "package.\" (CLHS glossary entry of `external')" (:newline))) + (:newline) + ,(display-link "internal" internal-symbols internal-symbols-length + :title (format nil "All internal symbols of package \"~A\"" package-name) + :description + '("A symbol is considered internal of a package if it's" (:newline) + "present and not external---that is if the package is" (:newline) + "the home package of the symbol, or if the symbol has" (:newline) + "been explicitly imported into the package." (:newline) + (:newline) + "Notice that inherited symbols will thus not be listed," (:newline) + "which deliberately deviates from the CLHS glossary" (:newline) + "entry of `internal' because it's assumed to be more" (:newline) + "useful this way." (:newline))) + (:newline) + ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols) + :title (format nil "All shadowed symbols of package \"~A\"" package-name) + :description nil))))))) + + +(defmethod inspect-for-emacs ((pathname pathname) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (values (if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + (append (label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname)))))) + +(defmethod inspect-for-emacs ((pathname logical-pathname) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (values "A logical pathname." + (append + (label-value-line* + ("Namestring" (namestring pathname)) + ("Physical pathname: " (translate-logical-pathname pathname))) + `("Host: " + ,(pathname-host pathname) + " (" (:value ,(logical-pathname-translations + (pathname-host pathname))) + "other translations)" + (:newline)) + (label-value-line* + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname)) + ("Truename" (if (not (wild-pathname-p pathname)) + (probe-file pathname))))))) + +(defmethod inspect-for-emacs ((n number) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (values "A number." `("Value: " ,(princ-to-string n)))) + +(defun format-iso8601-time (time-value &optional include-timezone-p) + "Formats a universal time TIME-VALUE in ISO 8601 format, with + the time zone included if INCLUDE-TIMEZONE-P is non-NIL" + ;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html + ;; Thanks, Nikolai Sandved and Thomas Russ! + (flet ((format-iso8601-timezone (zone) + (if (zerop zone) + "Z" + (multiple-value-bind (h m) (truncate (abs zone) 1.0) + ;; Tricky. Sign of time zone is reversed in ISO 8601 + ;; relative to Common Lisp convention! + (format nil "~:[+~;-~]~2,'0D:~2,'0D" + (> zone 0) h (round (* 60 m))))))) + (multiple-value-bind (second minute hour day month year dow dst zone) + (decode-universal-time time-value) + (declare (ignore dow dst)) + (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]" + year month day hour minute second + include-timezone-p (format-iso8601-timezone zone))))) + +(defmethod inspect-for-emacs ((i integer) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (values "A number." + (append + `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]" + i i i i (ignore-errors (coerce i 'float))) + (:newline)) + (when (< -1 i char-code-limit) + (label-value-line "Code-char" (code-char i))) + (label-value-line "Integer-length" (integer-length i)) + (ignore-errors + (label-value-line "Universal-time" (format-iso8601-time i t)))))) + +(defmethod inspect-for-emacs ((c complex) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (values "A complex number." + (label-value-line* + ("Real part" (realpart c)) + ("Imaginary part" (imagpart c))))) + +(defmethod inspect-for-emacs ((r ratio) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (values "A non-integer ratio." + (label-value-line* + ("Numerator" (numerator r)) + ("Denominator" (denominator r)) + ("As float" (float r))))) + +(defmethod inspect-for-emacs ((f float) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (values "A floating point number." + (cond + ((> f most-positive-long-float) + (list "Positive infinity.")) + ((< f most-negative-long-float) + (list "Negative infinity.")) + ((not (= f f)) + (list "Not a Number.")) + (t + (multiple-value-bind (significand exponent sign) (decode-float f) + (append + `("Scientific: " ,(format nil "~E" f) (:newline) + "Decoded: " + (:value ,sign) " * " + (:value ,significand) " * " + (:value ,(float-radix f)) "^" (:value ,exponent) (:newline)) + (label-value-line "Digits" (float-digits f)) + (label-value-line "Precision" (float-precision f)))))))) + +(defmethod inspect-for-emacs ((stream file-stream) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (multiple-value-bind (title content) + (call-next-method) + (declare (ignore title)) + (values "A file stream." + (append + `("Pathname: " + (:value ,(pathname stream)) + (:newline) " " + (:action "[visit file and show current position]" + ,(let ((pathname (pathname stream)) + (position (file-position stream))) + (lambda () + (ed-in-emacs `(,pathname :charpos ,position)))) + :refreshp nil) + (:newline)) + content)))) + +(defmethod inspect-for-emacs ((condition stream-error) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (multiple-value-bind (title content) + (call-next-method) + (let ((stream (stream-error-stream condition))) + (if (typep stream 'file-stream) + (values "A stream error." + (append + `("Pathname: " + (:value ,(pathname stream)) + (:newline) " " + (:action "[visit file and show current position]" + ,(let ((pathname (pathname stream)) + (position (file-position stream))) + (lambda () + (ed-in-emacs `(,pathname :charpos ,position)))) + :refreshp nil) + (:newline)) + content)) + (values title content))))) + +(defvar *fancy-inpector-undo-list* nil) + +(defslimefun fancy-inspector-init () + (let ((i *default-inspector*)) + (push (lambda () (setq *default-inspector* i)) + *fancy-inpector-undo-list*)) + (setq *default-inspector* (make-instance 'fancy-inspector)) + t) + +(defslimefun fancy-inspector-unload () + (loop while *fancy-inpector-undo-list* do + (funcall (pop *fancy-inpector-undo-list*)))) + +(provide :swank-fancy-inspector) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,620 @@ +;;; swank-fuzzy.lisp --- fuzzy symbol completion +;; +;; Authors: Brian Downing <bdowning(a)lavos.net> +;; Tobias C. Rittweiler <tcr(a)freebits.de> +;; and others +;; +;; License: Public Domain +;; + + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-c-p-c)) + +;;; For nomenclature of the fuzzy completion section, please read +;;; through the following docstring. + +(defslimefun fuzzy-completions (string default-package-name &key limit time-limit-in-msec) +"Returns a list of two values: + + An (optionally limited to LIMIT best results) list of fuzzy + completions for a symbol designator STRING. The list will be + sorted by score, most likely match first. + + A flag that indicates whether or not TIME-LIMIT-IN-MSEC has + been exhausted during computation. If that parameter's value is + NIL or 0, no time limit is assumed. + +The main result is a list of completion objects, where a completion +object is: + + (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS) + +where a CHUNK is a description of a matched substring: + + (OFFSET SUBSTRING) + +and FLAGS is a list of keywords describing properties of the +symbol (see CLASSIFY-SYMBOL). + +E.g., completing \"mvb\" in a package that uses COMMON-LISP would +return something like: + + ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\")) + (:FBOUNDP :MACRO)) + ...) + +If STRING is package qualified the result list will also be +qualified. If string is non-qualified the result strings are +also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. + +Which symbols are candidates for matching depends on the symbol +designator's format. The cases are as follows: + FOO - Symbols accessible in the buffer package. + PKG:FOO - Symbols external in package PKG. + PKG::FOO - Symbols accessible in package PKG." + ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC + ;; to denote an infinite time limit. Internally, we only use NIL for + ;; that purpose, to be able to distinguish between "no time limit + ;; alltogether" and "current time limit already exhausted." So we've + ;; got to canonicalize its value at first: + (let* ((no-time-limit-p (or (not time-limit-in-msec) (zerop time-limit-in-msec))) + (time-limit (if no-time-limit-p nil time-limit-in-msec))) + (multiple-value-bind (completion-set interrupted-p) + (fuzzy-completion-set string default-package-name :limit limit + :time-limit-in-msec time-limit) + ;; We may send this as elisp [] arrays to spare a coerce here, + ;; but then the network serialization were slower by handling arrays. + ;; Instead we limit the number of completions that is transferred + ;; (the limit is set from Emacs.) + (list (coerce completion-set 'list) interrupted-p)))) + + +;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion +;;; object that will be sent back to Emacs, as described above. + +(defstruct (fuzzy-matching (:conc-name fuzzy-matching.) + (:predicate fuzzy-matching-p) + (:constructor %make-fuzzy-matching)) + symbol ; The symbol that has been found to match. + package-name ; The name of the package where SYMBOL was found in. + ; (This is not necessarily the same as the home-package + ; of SYMBOL, because the SYMBOL can be internal to + ; lots of packages; also think of package nicknames.) + score ; The higher the better SYMBOL is a match. + package-chunks ; Chunks pertaining to the package identifier of SYMBOL. + symbol-chunks) ; Chunks pertaining to SYMBOL's name. + +(defun make-fuzzy-matching (symbol package-name score package-chunks symbol-chunks) + (declare (inline %make-fuzzy-matching)) + (%make-fuzzy-matching :symbol symbol :package-name package-name :score score + :package-chunks package-chunks + :symbol-chunks symbol-chunks)) + +(defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string) + (multiple-value-bind (_ user-package-name __ input-internal-p) + (parse-completion-arguments user-input-string nil) + (declare (ignore _ __)) + (with-struct (fuzzy-matching. score symbol package-name package-chunks symbol-chunks) + fuzzy-matching + (let (symbol-name real-package-name internal-p) + (cond (symbol ; symbol fuzzy matching? + (setf symbol-name (symbol-name symbol)) + (setf internal-p input-internal-p) + (setf real-package-name (cond ((keywordp symbol) "") + ((not user-package-name) nil) + (t package-name)))) + (t ; package fuzzy matching? + (setf symbol-name "") + (setf real-package-name package-name) + ;; If no explicit package name was given by the user + ;; (e.g. input was "asdf"), we want to append only + ;; one colon ":" to the package names. + (setf internal-p (if user-package-name input-internal-p nil)))) + (values symbol-name + real-package-name + (if user-package-name internal-p nil) + (completion-output-symbol-converter user-input-string) + (completion-output-package-converter user-input-string)))))) + +(defun fuzzy-format-matching (fuzzy-matching user-input-string) + "Returns the completion (\"foo:bar\") that's represented by FUZZY-MATCHING." + (multiple-value-bind (symbol-name package-name internal-p symbol-converter package-converter) + (%fuzzy-extract-matching-info fuzzy-matching user-input-string) + (setq symbol-name (and symbol-name (funcall symbol-converter symbol-name))) + (setq package-name (and package-name (funcall package-converter package-name))) + (let ((result (untokenize-symbol package-name internal-p symbol-name))) + ;; We return the length of the possibly added prefix as second value. + (values result (search symbol-name result))))) + +(defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string) + "Converts a result from the fuzzy completion core into +something that emacs is expecting. Converts symbols to strings, +fixes case issues, and adds information describing if the symbol +is :bound, :fbound, a :class, a :macro, a :generic-function, +a :special-operator, or a :package." + (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks) fuzzy-matching + (multiple-value-bind (name added-length) + (fuzzy-format-matching fuzzy-matching user-input-string) + (list name + score + (append package-chunks + (mapcar #'(lambda (chunk) + ;; Fix up chunk positions to account for possible + ;; added package identifier. + (let ((offset (first chunk)) (string (second chunk))) + (list (+ added-length offset) string))) + symbol-chunks)) + (classify-symbol symbol))))) + +(defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec) + "Returns two values: an array of completion objects, sorted by +their score, that is how well they are a match for STRING +according to the fuzzy completion algorithm. If LIMIT is set, +only the top LIMIT results will be returned. Additionally, a flag +is returned that indicates whether or not TIME-LIMIT-IN-MSEC was +exhausted." + (check-type limit (or null (integer 0 #.(1- most-positive-fixnum)))) + (check-type time-limit-in-msec (or null (integer 0 #.(1- most-positive-fixnum)))) + (multiple-value-bind (matchings interrupted-p) + (fuzzy-generate-matchings string default-package-name time-limit-in-msec) + (when (and limit + (> limit 0) + (< limit (length matchings))) + (if (array-has-fill-pointer-p matchings) + (setf (fill-pointer matchings) limit) + (setf matchings (make-array limit :displaced-to matchings)))) + (map-into matchings #'(lambda (m) + (fuzzy-convert-matching-for-emacs m string)) + matchings) + (values matchings interrupted-p))) + + +(defun fuzzy-generate-matchings (string default-package-name time-limit-in-msec) + "Does all the hard work for FUZZY-COMPLETION-SET. If +TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed." + (multiple-value-bind (parsed-symbol-name parsed-package-name package internal-p) + (parse-completion-arguments string default-package-name) + (flet ((fix-up (matchings parent-package-matching) + ;; The components of each matching in MATCHINGS have been computed + ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute. + (let* ((p parent-package-matching) + (p.name (fuzzy-matching.package-name p)) + (p.score (fuzzy-matching.score p)) + (p.chunks (fuzzy-matching.package-chunks p))) + (map-into matchings + #'(lambda (m) + (let ((m.score (fuzzy-matching.score m))) + (setf (fuzzy-matching.package-name m) p.name) + (setf (fuzzy-matching.package-chunks m) p.chunks) + (setf (fuzzy-matching.score m) + (if (equal parsed-symbol-name "") + ;; (Make package matchings be sorted before all the + ;; relative symbol matchings while preserving over + ;; all orderness.) + (/ p.score 100) + (+ p.score m.score))) + m)) + matchings))) + (find-symbols (designator package time-limit &optional filter) + (fuzzy-find-matching-symbols designator package + :time-limit-in-msec time-limit + :external-only (not internal-p) + :filter (or filter #'identity))) + (find-packages (designator time-limit) + (fuzzy-find-matching-packages designator :time-limit-in-msec time-limit))) + (let ((time-limit time-limit-in-msec) (symbols) (packages) (results)) + (cond ((not parsed-package-name) ; E.g. STRING = "asd" + ;; We don't know if user is searching for a package or a symbol + ;; within his current package. So we try to find either. + (setf (values packages time-limit) (find-packages parsed-symbol-name time-limit)) + (setf (values symbols time-limit) (find-symbols parsed-symbol-name package time-limit))) + ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo" + (setf (values symbols time-limit) (find-symbols parsed-symbol-name package time-limit))) + (t ; E.g. STRING = "asd:" or "asd:foo" + ;; Find fuzzy matchings of the denoted package identifier part. + ;; After that, find matchings for the denoted symbol identifier + ;; relative to all the packages found. + (multiple-value-bind (found-packages rest-time-limit) + (find-packages parsed-package-name time-limit-in-msec) + (loop + for package-matching across found-packages + for package = (find-package (fuzzy-matching.package-name package-matching)) + while (or (not time-limit) (> rest-time-limit 0)) do + (multiple-value-bind (matchings remaining-time) + ;; The filter removes all those symbols which are also present + ;; in one of the other packages, specifically if such a package + ;; represents the home package of the symbol, because that one + ;; is deemed to be the best match. + (find-symbols parsed-symbol-name package rest-time-limit + (%make-duplicate-symbols-filter + (remove package-matching found-packages))) + (setf matchings (fix-up matchings package-matching)) + (setf symbols (concatenate 'vector symbols matchings)) + (setf rest-time-limit remaining-time) + (let ((guessed-sort-duration (%guess-sort-duration (length symbols)))) + (when (<= rest-time-limit guessed-sort-duration) + (decf rest-time-limit guessed-sort-duration) + (loop-finish)))) + finally + (setf time-limit rest-time-limit) + (when (equal parsed-symbol-name "") ; E.g. STRING = "asd:" + (setf packages found-packages)))))) + ;; Sort by score; thing with equal score, sort alphabetically. + ;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all possible + ;; completions are to be returned.) + (setf results (concatenate 'vector symbols packages)) + (setf results (sort results #'fuzzy-matching-greaterp)) + (values results (and time-limit (<= time-limit 0))))))) + +(defun %guess-sort-duration (length) + ;; These numbers are pretty much arbitrary, except that they're + ;; vaguely correct on my machine with SBCL. Yes, this is an ugly + ;; kludge, but it's better than before (where this didn't exist at + ;; all, which essentially meant, that this was taken to be 0.) + (if (zerop length) + 0 + (let ((comparasions (* 3.8 (* length (log length 2))))) + (* 1000 (* comparasions (expt 10 -7)))))) ; msecs + +(defun %make-duplicate-symbols-filter (fuzzy-package-matchings) + ;; Returns a filter function that takes a symbol and which returns T + ;; only if no matching in FUZZY-PACKAGE-MATCHINGS represents the + ;; home-package of the. + (let ((packages (mapcar #'(lambda (m) + (find-package (fuzzy-matching.package-name m))) + (coerce fuzzy-package-matchings 'list)))) + #'(lambda (symbol) + (not (member (symbol-package symbol) packages))))) + +(defun fuzzy-matching-greaterp (m1 m2) + "Returns T if fuzzy-matching M1 should be sorted before M2. +Basically just the scores of the two matchings are compared, and +the match with higher score wins. For the case that the score is +equal, the one which comes alphabetically first wins." + (declare (type fuzzy-matching m1 m2)) + (let ((score1 (fuzzy-matching.score m1)) + (score2 (fuzzy-matching.score m2))) + (cond ((> score1 score2) t) + ((< score1 score2) nil) ; total order + (t + (let ((name1 (symbol-name (fuzzy-matching.symbol m1))) + (name2 (symbol-name (fuzzy-matching.symbol m2)))) + (string< name1 name2)))))) + + +(defun get-real-time-in-msecs () + (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000)))) + (values (floor (get-internal-real-time) units-per-msec)))) ; return just one value! + +(defun fuzzy-find-matching-symbols + (string package &key (filter #'identity) external-only time-limit-in-msec) + "Returns two values: a vector of fuzzy matchings for matching +symbols in PACKAGE, using the fuzzy completion algorithm, and the +remaining time limit. + +Only those symbols are considered of which FILTER does return T. + +If EXTERNAL-ONLY is true, only external symbols are considered. A +TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or +negative, perform a NOP." + (let ((time-limit-p (and time-limit-in-msec t)) + (time-limit (or time-limit-in-msec 0)) + (rtime-at-start (get-real-time-in-msecs)) + (package-name (package-name package)) + (count 0)) + (declare (type boolean time-limit-p)) + (declare (type integer time-limit rtime-at-start)) + (declare (type (integer 0 #.(1- most-positive-fixnum)) count)) + + (flet ((recompute-remaining-time (old-remaining-time) + (cond ((not time-limit-p) + (values nil nil)) ; propagate NIL back as infinite time limit. + ((> count 0) ; ease up on getting internal time like crazy. + (setf count (mod (1+ count) 128)) + (values nil old-remaining-time)) + (t (let* ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start)) + (remaining (- time-limit elapsed-time))) + (values (<= remaining 0) remaining))))) + (perform-fuzzy-match (string symbol-name) + (let* ((converter (completion-output-symbol-converter string)) + (converted-symbol-name (funcall converter symbol-name))) + (compute-highest-scoring-completion string converted-symbol-name)))) + (let ((completions (make-array 256 :adjustable t :fill-pointer 0)) + (rest-time-limit time-limit)) + (block loop + (do-symbols* (symbol package) + (multiple-value-bind (exhausted? remaining-time) + (recompute-remaining-time rest-time-limit) + (setf rest-time-limit remaining-time) + (cond (exhausted? (return-from loop)) + ((or (not external-only) (symbol-external-p symbol package)) + (when (funcall filter symbol) + (if (string= "" string) ; "" matches always + (vector-push-extend (make-fuzzy-matching symbol package-name + 0.0 '() '()) + completions) + (multiple-value-bind (match-result score) + (perform-fuzzy-match string (symbol-name symbol)) + (when match-result + (vector-push-extend + (make-fuzzy-matching symbol package-name score + '() match-result) + completions)))))))))) + (values completions rest-time-limit))))) + + +(defun fuzzy-find-matching-packages (name &key time-limit-in-msec) + "Returns a vector of fuzzy matchings for each package that is +similiar to NAME, and the remaining time limit. +Cf. FUZZY-FIND-MATCHING-SYMBOLS." + (let ((time-limit-p (and time-limit-in-msec t)) + (time-limit (or time-limit-in-msec 0)) + (rtime-at-start (get-real-time-in-msecs)) + (converter (completion-output-package-converter name)) + (completions (make-array 32 :adjustable t :fill-pointer 0))) + (declare (type boolean time-limit-p)) + (declare (type integer time-limit rtime-at-start)) + (declare (type function converter)) + (if (and time-limit-p (<= time-limit 0)) + (values #() time-limit) + (loop for package in (list-all-packages) do + ;; Find best-matching package-nickname: + (loop with max-pkg-name = "" + with max-result = nil + with max-score = 0 + for package-name in (package-names package) + for converted-name = (funcall converter package-name) + do + (multiple-value-bind (result score) + (compute-highest-scoring-completion name converted-name) + (when (and result (> score max-score)) + (setf max-pkg-name package-name) + (setf max-result result) + (setf max-score score))) + finally + (when max-result + (vector-push-extend (make-fuzzy-matching nil max-pkg-name + max-score max-result '()) + completions))) + finally + (return + (values completions + (and time-limit-p + (let ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start))) + (- time-limit elapsed-time))))))))) + + +(defslimefun fuzzy-completion-selected (original-string completion) + "This function is called by Slime when a fuzzy completion is +selected by the user. It is for future expansion to make +testing, say, a machine learning algorithm for completion scoring +easier. + +ORIGINAL-STRING is the string the user completed from, and +COMPLETION is the completion object (see docstring for +SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the +user selected." + (declare (ignore original-string completion)) + nil) + + +;;;;; Fuzzy completion core + +(defparameter *fuzzy-recursion-soft-limit* 30 + "This is a soft limit for recursion in +RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit, +completing a string such as \"ZZZZZZ\" with a symbol named +\"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to +find all the ways it can match. + +Most natural language searches and symbols do not have this +problem -- this is only here as a safeguard.") +(declaim (fixnum *fuzzy-recursion-soft-limit*)) + +(defun compute-highest-scoring-completion (short full) + "Finds the highest scoring way to complete the abbreviation +SHORT onto the string FULL, using CHAR= as a equality function for +letters. Returns two values: The first being the completion +chunks of the highest scorer, and the second being the score." + (let* ((scored-results + (mapcar #'(lambda (result) + (cons (score-completion result short full) result)) + (compute-most-completions short full))) + (winner (first (sort scored-results #'> :key #'first)))) + (values (rest winner) (first winner)))) + +(defun compute-most-completions (short full) + "Finds most possible ways to complete FULL with the letters in SHORT. +Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns +a list of (&rest CHUNKS), where each CHUNKS is a description of +how a completion matches." + (let ((*all-chunks* nil)) + (declare (special *all-chunks*)) + (recursively-compute-most-completions short full 0 0 nil nil nil t) + *all-chunks*)) + +(defun recursively-compute-most-completions + (short full + short-index initial-full-index + chunks current-chunk current-chunk-pos + recurse-p) + "Recursively (if RECURSE-P is true) find /most/ possible ways +to fuzzily map the letters in SHORT onto FULL, using CHAR= to +determine if two letters match. + +A chunk is a list of elements that have matched consecutively. +When consecutive matches stop, it is coerced into a string, +paired with the starting position of the chunk, and pushed onto +CHUNKS. + +Whenever a letter matches, if RECURSE-P is true, +RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position +one index ahead, to find other possibly higher scoring +possibilities. If there are less than +*FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently, +this call will also recurse. + +Once a word has been completely matched, the chunks are pushed +onto the special variable *ALL-CHUNKS* and the function returns." + (declare ;(optimize speed) + (fixnum short-index initial-full-index) + (simple-string short full) + (special *all-chunks*)) + (flet ((short-cur () + "Returns the next letter from the abbreviation, or NIL + if all have been used." + (if (= short-index (length short)) + nil + (aref short short-index))) + (add-to-chunk (char pos) + "Adds the CHAR at POS in FULL to the current chunk, + marking the start position if it is empty." + (unless current-chunk + (setf current-chunk-pos pos)) + (push char current-chunk)) + (collect-chunk () + "Collects the current chunk to CHUNKS and prepares for + a new chunk." + (when current-chunk + (push (list current-chunk-pos + (coerce (reverse current-chunk) 'string)) chunks) + (setf current-chunk nil + current-chunk-pos nil)))) + ;; If there's an outstanding chunk coming in collect it. Since + ;; we're recursively called on skipping an input character, the + ;; chunk can't possibly continue on. + (when current-chunk (collect-chunk)) + (do ((pos initial-full-index (1+ pos))) + ((= pos (length full))) + (let ((cur-char (aref full pos))) + (if (and (short-cur) + (char= cur-char (short-cur))) + (progn + (when recurse-p + ;; Try other possibilities, limiting insanely deep + ;; recursion somewhat. + (recursively-compute-most-completions + short full short-index (1+ pos) + chunks current-chunk current-chunk-pos + (not (> (length *all-chunks*) + *fuzzy-recursion-soft-limit*)))) + (incf short-index) + (add-to-chunk cur-char pos)) + (collect-chunk)))) + (collect-chunk) + ;; If we've exhausted the short characters we have a match. + (if (short-cur) + nil + (let ((rev-chunks (reverse chunks))) + (push rev-chunks *all-chunks*) + rev-chunks)))) + + +;;;;; Fuzzy completion scoring + +(defparameter *fuzzy-completion-symbol-prefixes* "*+-%&?<" + "Letters that are likely to be at the beginning of a symbol. +Letters found after one of these prefixes will be scored as if +they were at the beginning of ths symbol.") +(defparameter *fuzzy-completion-symbol-suffixes* "*+->" + "Letters that are likely to be at the end of a symbol. +Letters found before one of these suffixes will be scored as if +they were at the end of the symbol.") +(defparameter *fuzzy-completion-word-separators* "-/." + "Letters that separate different words in symbols. Letters +after one of these symbols will be scores more highly than other +letters.") + +(defun score-completion (completion short full) + "Scores the completion chunks COMPLETION as a completion from +the abbreviation SHORT to the full string FULL. COMPLETION is a +list like: + ((0 \"mul\") (9 \"v\") (15 \"b\")) +Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\", +would indicate that it completed as such (completed letters +capitalized): + MULtiple-Value-Bind + +Letters are given scores based on their position in the string. +Letters at the beginning of a string or after a prefix letter at +the beginning of a string are scored highest. Letters after a +word separator such as #\- are scored next highest. Letters at +the end of a string or before a suffix letter at the end of a +string are scored medium, and letters anywhere else are scored +low. + +If a letter is directly after another matched letter, and its +intrinsic value in that position is less than a percentage of the +previous letter's value, it will use that percentage instead. + +Finally, a small scaling factor is applied to favor shorter +matches, all other things being equal." + (labels ((at-beginning-p (pos) + (= pos 0)) + (after-prefix-p (pos) + (and (= pos 1) + (find (aref full 0) *fuzzy-completion-symbol-prefixes*))) + (word-separator-p (pos) + (find (aref full pos) *fuzzy-completion-word-separators*)) + (after-word-separator-p (pos) + (find (aref full (1- pos)) *fuzzy-completion-word-separators*)) + (at-end-p (pos) + (= pos (1- (length full)))) + (before-suffix-p (pos) + (and (= pos (- (length full) 2)) + (find (aref full (1- (length full))) + *fuzzy-completion-symbol-suffixes*))) + (score-or-percentage-of-previous (base-score pos chunk-pos) + (if (zerop chunk-pos) + base-score + (max base-score + (+ (* (score-char (1- pos) (1- chunk-pos)) 0.85) + (expt 1.2 chunk-pos))))) + (score-char (pos chunk-pos) + (score-or-percentage-of-previous + (cond ((at-beginning-p pos) 10) + ((after-prefix-p pos) 10) + ((word-separator-p pos) 1) + ((after-word-separator-p pos) 8) + ((at-end-p pos) 6) + ((before-suffix-p pos) 6) + (t 1)) + pos chunk-pos)) + (score-chunk (chunk) + (loop for chunk-pos below (length (second chunk)) + for pos from (first chunk) + summing (score-char pos chunk-pos)))) + (let* ((chunk-scores (mapcar #'score-chunk completion)) + (length-score (/ 10.0 (1+ (- (length full) (length short)))))) + (values + (+ (reduce #'+ chunk-scores) length-score) + (list (mapcar #'list chunk-scores completion) length-score))))) + +(defun highlight-completion (completion full) + "Given a chunk definition COMPLETION and the string FULL, +HIGHLIGHT-COMPLETION will create a string that demonstrates where +the completion matched in the string. Matches will be +capitalized, while the rest of the string will be lower-case." + (let ((highlit (nstring-downcase (copy-seq full)))) + (dolist (chunk completion) + (setf highlit (nstring-upcase highlit + :start (first chunk) + :end (+ (first chunk) + (length (second chunk)))))) + highlit)) + +(defun format-fuzzy-completion-set (winners) + "Given a list of completion objects such as on returned by +FUZZY-COMPLETION-SET, format the list into user-readable output +for interactive debugging purpose." + (let ((max-len + (loop for winner in winners maximizing (length (first winner))))) + (loop for (sym score result) in winners do + (format t "~&~VA score ~8,2F ~A" + max-len (highlight-completion result sym) score result)))) + +(provide :swank-fuzzy) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-listener-hooks.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-listener-hooks.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-listener-hooks.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,82 @@ +;;; swank-listener-hooks.lisp --- listener with special hooks +;; +;; Author: Alan Ruttenberg <alanr-l(a)mumble.net> + +;; I guess that only Alan Ruttenberg knows how to use this code. It +;; was in swank.lisp for a long time, so here it is. -- Helmut Eller + +(defvar *slime-repl-advance-history* nil + "In the dynamic scope of a single form typed at the repl, is set to nil to + prevent the repl from advancing the history - * ** *** etc.") + +(defvar *slime-repl-suppress-output* nil + "In the dynamic scope of a single form typed at the repl, is set to nil to + prevent the repl from printing the result of the evalation.") + +(defvar *slime-repl-eval-hook-pass* (gensym "PASS") + "Token to indicate that a repl hook declines to evaluate the form") + +(defvar *slime-repl-eval-hooks* nil + "A list of functions. When the repl is about to eval a form, first try running each of + these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass* + is considered a replacement for calling eval. If there are no hooks, or all + pass, then eval is used.") + +(defslimefun repl-eval-hook-pass () + "call when repl hook declines to evaluate the form" + (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*)) + +(defslimefun repl-suppress-output () + "In the dynamic scope of a single form typed at the repl, call to + prevent the repl from printing the result of the evalation." + (setq *slime-repl-suppress-output* t)) + +(defslimefun repl-suppress-advance-history () + "In the dynamic scope of a single form typed at the repl, call to + prevent the repl from advancing the history - * ** *** etc." + (setq *slime-repl-advance-history* nil)) + +(defun %eval-region (string) + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (fresh-line) + (finish-output) + (return (values values -))) + (setq - form) + (if *slime-repl-eval-hooks* + (setq values (run-repl-eval-hooks form)) + (setq values (multiple-value-list (eval form)))) + (finish-output)))))) + +(defun run-repl-eval-hooks (form) + (loop for hook in *slime-repl-eval-hooks* + for res = (catch *slime-repl-eval-hook-pass* + (multiple-value-list (funcall hook form))) + until (not (eq res *slime-repl-eval-hook-pass*)) + finally (return + (if (eq res *slime-repl-eval-hook-pass*) + (multiple-value-list (eval form)) + res)))) + +(defun %listener-eval (string) + (clear-user-input) + (with-buffer-syntax () + (track-package + (lambda () + (let ((*slime-repl-suppress-output* :unset) + (*slime-repl-advance-history* :unset)) + (multiple-value-bind (values last-form) (%eval-region string) + (unless (or (and (eq values nil) (eq last-form nil)) + (eq *slime-repl-advance-history* nil)) + (setq *** ** ** * * (car values) + /// // // / / values)) + (setq +++ ++ ++ + + last-form) + (unless (eq *slime-repl-suppress-output* t) + (funcall *send-repl-results-function* values)))))))) + +(setq *listener-eval-function* '%listener-eval) + +(provide :swank-listener-hooks) Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,319 @@ +;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities +;;; to portions of output +;;; +;;; Authors: Alan Ruttenberg <alanr-l(a)mumble.net> +;;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> +;;; Helmut Eller <heller(a)common-lisp.net> +;;; +;;; License: This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(in-package :swank) + +(swank-require :swank-presentations) + +;; This file contains a mechanism for printing to the slime repl so +;; that the printed result remembers what object it is associated +;; with. This extends the recording of REPL results. +;; +;; There are two methods: +;; +;; 1. Depends on the ilisp bridge code being installed and ready to +;; intercept messages in the printed stream. We encode the +;; information with a message saying that we are starting to print +;; an object corresponding to a given id and another when we are +;; done. The process filter notices these and adds the necessary +;; text properties to the output. +;; +;; 2. Use separate protocol messages :presentation-start and +;; :presentation-end for sending presentations. +;; +;; We only do this if we know we are printing to a slime stream, +;; checked with the method slime-stream-p. Initially this checks for +;; the knows slime streams looking at *connections*. In cmucl, sbcl, and +;; openmcl it also checks if it is a pretty-printing stream which +;; ultimately prints to a slime stream. +;; +;; Method 1 seems to be faster, but the printed escape sequences can +;; disturb the column counting, and thus the layout in pretty-printing. +;; We use method 1 when a dedicated output stream is used. +;; +;; Method 2 is cleaner and works with pretty printing if the pretty +;; printers support "annotations". We use method 2 when no dedicated +;; output stream is used. + +;; Control +(defvar *enable-presenting-readable-objects* t + "set this to enable automatically printing presentations for some +subset of readable objects, such as pathnames." ) + +;; doing it + +(defmacro presenting-object (object stream &body body) + "What you use in your code. Wrap this around some printing and that text will +be sensitive and remember what object it is in the repl" + `(presenting-object-1 ,object ,stream #'(lambda () ,@body))) + +(defmacro presenting-object-if (predicate object stream &body body) + "What you use in your code. Wrap this around some printing and that text will +be sensitive and remember what object it is in the repl if predicate is true" + (let ((continue (gensym))) + `(let ((,continue #'(lambda () ,@body))) + (if ,predicate + (presenting-object-1 ,object ,stream ,continue) + (funcall ,continue))))) + +;;; Get pretty printer patches for SBCL at load (not compile) time. +#+sbcl +(eval-when (:load-toplevel) + (handler-bind ((simple-error + (lambda (c) + (declare (ignore c)) + (let ((clobber-it (find-restart 'sb-kernel::clobber-it))) + (when clobber-it (invoke-restart clobber-it)))))) + (sb-ext:without-package-locks + (swank-backend::with-debootstrapping + (load (make-pathname + :name "sbcl-pprint-patch" + :type "lisp" + :directory (pathname-directory swank-loader:*source-directory*))))))) + +(let ((last-stream nil) + (last-answer nil)) + (defun slime-stream-p (stream) + "Check if stream is one of the slime streams, since if it isn't we +don't want to present anything. +Two special return values: +:DEDICATED -- Output ends up on a dedicated output stream +:REPL-RESULT -- Output ends up on the :repl-results target. +" + (if (eq last-stream stream) + last-answer + (progn + (setq last-stream stream) + (if (eq stream t) + (setq stream *standard-output*)) + (setq last-answer + (or #+openmcl + (and (typep stream 'ccl::xp-stream) + ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure))) + (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1))) + #+cmu + (or (and (typep stream 'lisp::indenting-stream) + (slime-stream-p (lisp::indenting-stream-stream stream))) + (and (typep stream 'pretty-print::pretty-stream) + (fboundp 'pretty-print::enqueue-annotation) + (let ((slime-stream-p + (slime-stream-p (pretty-print::pretty-stream-target stream)))) + (and ;; Printing through CMUCL pretty + ;; streams is only cleanly + ;; possible if we are using the + ;; bridge-less protocol with + ;; annotations, because the bridge + ;; escape sequences disturb the + ;; pretty printer layout. + (not (eql slime-stream-p :dedicated-output)) + ;; If OK, return the return value + ;; we got from slime-stream-p on + ;; the target stream (could be + ;; :repl-result): + slime-stream-p)))) + #+sbcl + (let () + (declare (notinline sb-pretty::pretty-stream-target)) + (or (and (typep stream 'sb-impl::indenting-stream) + (slime-stream-p (sb-impl::indenting-stream-stream stream))) + (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)) + (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty) + (not *use-dedicated-output-stream*) + (slime-stream-p (sb-pretty::pretty-stream-target stream))))) + #+allegro + (and (typep stream 'excl:xp-simple-stream) + (slime-stream-p (excl::stream-output-handle stream))) + (loop for connection in *connections* + thereis (or (and (eq stream (connection.dedicated-output connection)) + :dedicated) + (eq stream (connection.socket-io connection)) + (eq stream (connection.user-output connection)) + (eq stream (connection.user-io connection)) + (and (eq stream (connection.repl-results connection)) + :repl-result))))))))) + +(defun can-present-readable-objects (&optional stream) + (declare (ignore stream)) + *enable-presenting-readable-objects*) + +;; If we are printing to an XP (pretty printing) stream, printing the +;; escape sequences directly would mess up the layout because column +;; counting is disturbed. Use "annotations" instead. +#+allegro +(defun write-annotation (stream function arg) + (if (typep stream 'excl:xp-simple-stream) + (excl::schedule-annotation stream function arg) + (funcall function arg stream nil))) +#+cmu +(defun write-annotation (stream function arg) + (if (and (typep stream 'pp:pretty-stream) + (fboundp 'pp::enqueue-annotation)) + (pp::enqueue-annotation stream function arg) + (funcall function arg stream nil))) +#+sbcl +(defun write-annotation (stream function arg) + (let ((enqueue-annotation + (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty))) + (if (and enqueue-annotation + (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))) + (funcall enqueue-annotation stream function arg) + (funcall function arg stream nil)))) +#-(or allegro cmu sbcl) +(defun write-annotation (stream function arg) + (funcall function arg stream nil)) + +(defstruct presentation-record + (id) + (printed-p) + (target)) + +(defun presentation-start (record stream truncatep) + (unless truncatep + ;; Don't start new presentations when nothing is going to be + ;; printed due to *print-lines*. + (let ((pid (presentation-record-id record)) + (target (presentation-record-target record))) + (case target + (:dedicated + ;; Use bridge protocol + (write-string "<" stream) + (prin1 pid stream) + (write-string "" stream)) + (t + (finish-output stream) + (send-to-emacs `(:presentation-start ,pid ,target))))) + (setf (presentation-record-printed-p record) t))) + +(defun presentation-end (record stream truncatep) + (declare (ignore truncatep)) + ;; Always end old presentations that were started. + (when (presentation-record-printed-p record) + (let ((pid (presentation-record-id record)) + (target (presentation-record-target record))) + (case target + (:dedicated + ;; Use bridge protocol + (write-string ">" stream) + (prin1 pid stream) + (write-string "" stream)) + (t + (finish-output stream) + (send-to-emacs `(:presentation-end ,pid ,target))))))) + +(defun presenting-object-1 (object stream continue) + "Uses the bridge mechanism with two messages >id and <id. The first one +says that I am starting to print an object with this id. The second says I am finished" + (let ((slime-stream-p + (and *record-repl-results* (slime-stream-p stream)))) + (if slime-stream-p + (let* ((pid (swank::save-presented-object object)) + (record (make-presentation-record :id pid :printed-p nil + :target (if (eq slime-stream-p :repl-result) + :repl-result + nil)))) + (write-annotation stream #'presentation-start record) + (multiple-value-prog1 + (funcall continue) + (write-annotation stream #'presentation-end record))) + (funcall continue)))) + +(defun present-repl-results-via-presentation-streams (values) + ;; Override a function in swank.lisp, so that + ;; nested presentations work in the REPL result. + (let ((repl-results (connection.repl-results *emacs-connection*))) + (flet ((send (value) + (presenting-object value repl-results + (prin1 value repl-results)) + (terpri repl-results))) + (if (null values) + (progn + (princ "; No value" repl-results) + (terpri repl-results)) + (mapc #'send values))) + (finish-output repl-results))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Example: Tell openmcl and cmucl to always present unreadable objects. try (describe 'class) +#+openmcl +(in-package :ccl) +#+openmcl +(let ((*warn-if-redefine-kernel* nil) + (*warn-if-redefine* nil)) + (defun %print-unreadable-object (object stream type id thunk) + (cond ((null stream) (setq stream *standard-output*)) + ((eq stream t) (setq stream *terminal-io*))) + (swank::presenting-object object stream + (write-unreadable-start object stream) + (when type + (princ (type-of object) stream) + (stream-write-char stream #\space)) + (when thunk + (funcall thunk)) + (if id + (%write-address object stream #\>) + (pp-end-block stream ">")) + nil)) + (defmethod print-object :around ((pathname pathname) stream) + (swank::presenting-object-if + (swank::can-present-readable-objects stream) + pathname stream (call-next-method)))) + +#+openmcl +(ccl::def-load-pointers clear-presentations () + (swank::clear-presentation-tables)) + +(in-package :swank) + +#+cmu +(progn + (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body) + (presenting-object object stream + (fwrappers:call-next-function))) + + (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth) + (presenting-object-if (can-present-readable-objects stream) pathname stream + (fwrappers:call-next-function))) + + (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper) + (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper) + ) + +#+sbcl +(progn + (defvar *saved-%print-unreadable-object* + (fdefinition 'sb-impl::%print-unreadable-object)) + (sb-ext:without-package-locks + (setf (fdefinition 'sb-impl::%print-unreadable-object) + (lambda (object stream type identity body) + (presenting-object object stream + (funcall *saved-%print-unreadable-object* + object stream type identity body)))) + (defmethod print-object :around ((object pathname) stream) + (presenting-object object stream + (call-next-method))))) + +#+allegro +(progn + (excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation) + (swank::presenting-object object stream (excl:call-next-fwrapper))) + (excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth) + (presenting-object-if (can-present-readable-objects stream) pathname stream + (excl:call-next-fwrapper))) + (excl:fwrap 'excl::print-unreadable-object-1 + 'print-unreadable-present 'presenting-unreadable-wrapper) + (excl:fwrap 'excl::pathname-printer + 'print-pathname-present 'presenting-pathname-wrapper)) + +;; Hook into SWANK. + +(setq *send-repl-results-function* 'present-repl-results-via-presentation-streams) + +(provide :swank-presentation-streams) Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-presentations.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-presentations.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-presentations.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,235 @@ +;;; swank-presentations.lisp --- imitate LispM's presentations +;; +;; Authors: Alan Ruttenberg <alanr-l(a)mumble.net> +;; Luke Gorrie <luke(a)synap.se> +;; Helmut Eller <heller(a)common-lisp.net> +;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> +;; +;; License: This code has been placed in the Public Domain. All warranties +;; are disclaimed. +;; + +(in-package :swank) + +;;;; Recording and accessing results of computations + +(defvar *record-repl-results* t + "Non-nil means that REPL results are saved for later lookup.") + +(defvar *object-to-presentation-id* + (make-weak-key-hash-table :test 'eq) + "Store the mapping of objects to numeric identifiers") + +(defvar *presentation-id-to-object* + (make-weak-value-hash-table :test 'eql) + "Store the mapping of numeric identifiers to objects") + +(defun clear-presentation-tables () + (clrhash *object-to-presentation-id*) + (clrhash *presentation-id-to-object*)) + +(defvar *presentation-counter* 0 "identifier counter") + +(defvar *nil-surrogate* (make-symbol "nil-surrogate")) + +;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the +;; rest of slime isn't thread safe either), do we really care? +(defun save-presented-object (object) + "Save OBJECT and return the assigned id. +If OBJECT was saved previously return the old id." + (let ((object (if (null object) *nil-surrogate* object))) + ;; We store *nil-surrogate* instead of nil, to distinguish it from + ;; an object that was garbage collected. + (or (gethash object *object-to-presentation-id*) + (let ((id (incf *presentation-counter*))) + (setf (gethash id *presentation-id-to-object*) object) + (setf (gethash object *object-to-presentation-id*) id) + id)))) + +(defun lookup-presented-object (id) + "Retrieve the object corresponding to ID. +The secondary value indicates the absence of an entry." + (etypecase id + (integer + ;; + (multiple-value-bind (object foundp) + (gethash id *presentation-id-to-object*) + (cond + ((eql object *nil-surrogate*) + ;; A stored nil object + (values nil t)) + ((null object) + ;; Object that was replaced by nil in the weak hash table + ;; when the object was garbage collected. + (values nil nil)) + (t + (values object foundp))))) + (cons + (destructure-case id + ((:frame-var thread-id frame index) + (declare (ignore thread-id)) ; later + (handler-case + (frame-var-value frame index) + (t (condition) + (declare (ignore condition)) + (values nil nil)) + (:no-error (value) + (values value t)))) + ((:inspected-part part-index) + (declare (special *inspectee-parts*)) + (if (< part-index (length *inspectee-parts*)) + (values (inspector-nth-part part-index) t) + (values nil nil))))))) + +(defslimefun get-repl-result (id) + "Get the result of the previous REPL evaluation with ID." + (multiple-value-bind (object foundp) (lookup-presented-object id) + (cond (foundp object) + (t (error "Attempt to access unrecorded object (id ~D)." id))))) + +(defslimefun clear-repl-results () + "Forget the results of all previous REPL evaluations." + (clear-presentation-tables) + t) + +(defun present-repl-results (values) + ;; Override a function in swank.lisp, so that + ;; presentations are associated with every REPL result. + (flet ((send (value) + (let ((id (and *record-repl-results* + (save-presented-object value)))) + (send-to-emacs `(:presentation-start ,id :repl-result)) + (send-to-emacs `(:write-string ,(prin1-to-string value) + :repl-result)) + (send-to-emacs `(:presentation-end ,id :repl-result)) + (send-to-emacs `(:write-string ,(string #\Newline) + :repl-result))))) + (if (null values) + (send-to-emacs `(:write-string "; No value" :repl-result)) + (mapc #'send values)))) + + +;;;; Presentation menu protocol +;; +;; To define a menu for a type of object, define a method +;; menu-choices-for-presentation on that object type. This function +;; should return a list of two element lists where the first element is +;; the name of the menu action and the second is a function that will be +;; called if the menu is chosen. The function will be called with 3 +;; arguments: +;; +;; choice: The string naming the action from above +;; +;; object: The object +;; +;; id: The presentation id of the object +;; +;; You might want append (when (next-method-p) (call-next-method)) to +;; pick up the Menu actions of superclasses. +;; + +(defvar *presentation-active-menu* nil) + +(defun menu-choices-for-presentation-id (id) + (multiple-value-bind (ob presentp) (lookup-presented-object id) + (cond ((not presentp) 'not-present) + (t + (let ((menu-and-actions (menu-choices-for-presentation ob))) + (setq *presentation-active-menu* (cons id menu-and-actions)) + (mapcar 'car menu-and-actions)))))) + +(defun swank-ioify (thing) + (cond ((keywordp thing) thing) + ((and (symbolp thing)(not (find #\: (symbol-name thing)))) + (intern (symbol-name thing) 'swank-io-package)) + ((consp thing) (cons (swank-ioify (car thing)) (swank-ioify (cdr thing)))) + (t thing))) + +(defun execute-menu-choice-for-presentation-id (id count item) + (let ((ob (lookup-presented-object id))) + (assert (equal id (car *presentation-active-menu*)) () + "Bug: Execute menu call for id ~a but menu has id ~a" + id (car *presentation-active-menu*)) + (let ((action (second (nth (1- count) (cdr *presentation-active-menu*))))) + (swank-ioify (funcall action item ob id))))) + + +(defgeneric menu-choices-for-presentation (object) + (:method (ob) (declare (ignore ob)) nil)) ; default method + +;; Pathname +(defmethod menu-choices-for-presentation ((ob pathname)) + (let* ((file-exists (ignore-errors (probe-file ob))) + (lisp-type (make-pathname :type "lisp")) + (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal)) + (let ((source (merge-pathnames lisp-type ob))) + (and (ignore-errors (probe-file source)) + source)))) + (fasl-file (and file-exists + (equal (ignore-errors + (namestring + (truename + (compile-file-pathname + (merge-pathnames lisp-type ob))))) + (namestring (truename ob)))))) + (remove nil + (list* + (and (and file-exists (not fasl-file)) + (list "Edit this file" + (lambda(choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring (truename object))) + nil))) + (and file-exists + (list "Dired containing directory" + (lambda (choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring + (truename + (merge-pathnames + (make-pathname :name "" :type "") object)))) + nil))) + (and fasl-file + (list "Load this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (load ob) + nil))) + (and fasl-file + (list "Delete this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (let ((nt (namestring (truename ob)))) + (when (y-or-n-p-in-emacs "Delete ~a? " nt) + (delete-file nt))) + nil))) + (and source-file + (list "Edit lisp source file" + (lambda (choice object id) + (declare (ignore choice id object)) + (ed-in-emacs (namestring (truename source-file))) + nil))) + (and source-file + (list "Load lisp source file" + (lambda(choice object id) + (declare (ignore choice id object)) + (load source-file) + nil))) + (and (next-method-p) (call-next-method)))))) + +(defmethod menu-choices-for-presentation ((ob function)) + (list (list "Disassemble" + (lambda (choice object id) + (declare (ignore choice id)) + (disassemble object))))) + +(defslimefun inspect-presentation (id reset-p) + (let ((what (lookup-presented-object id))) + (when reset-p + (reset-inspector)) + (inspect-object what))) + + +(setq *send-repl-results-function* 'present-repl-results) + +(provide :swank-presentations) Added: branches/trunk-reorg/thirdparty/slime/doc/.cvsignore =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/.cvsignore 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/.cvsignore 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,15 @@ +contributors.texi +slime.aux +slime.cp +slime.dvi +slime.fn +slime.info +slime.ky +slime.log +slime.pdf +slime.pg +slime.ps +slime.tmp +slime.toc +slime.tp +slime.vr Added: branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,9 @@ +/.cvsignore/1.1/Mon Jul 24 14:13:23 2006// +/Makefile/1.12/Mon Sep 17 14:04:27 2007// +/slime-refcard.pdf/1.1/Thu Aug 9 09:18:50 2007// +/slime-refcard.tex/1.1/Thu Aug 9 09:18:50 2007// +/slime-small.eps/1.1/Wed Nov 22 06:27:38 2006// +/slime-small.pdf/1.1/Wed Nov 22 06:27:38 2006// +/slime.texi/1.57/Mon Sep 17 13:44:48 2007// +/texinfo-tabulate.awk/1.2/Mon Aug 29 20:02:57 2005// +D Added: branches/trunk-reorg/thirdparty/slime/doc/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/CVS/Repository 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/CVS/Repository 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1 @@ +slime/doc Added: branches/trunk-reorg/thirdparty/slime/doc/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/CVS/Root 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/CVS/Root 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1 @@ +:pserver:anonymous:anonymous@common-lisp.net:/project/slime/cvsroot Added: branches/trunk-reorg/thirdparty/slime/doc/CVS/Template =================================================================== Added: branches/trunk-reorg/thirdparty/slime/doc/Makefile =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/Makefile 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/Makefile 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,97 @@ +# This file has been placed in the public domain. +# +# Where to put the info file(s). NB: the GNU Coding Standards (GCS) +# and the Filesystem Hierarchy Standard (FHS) differ on where info +# files belong. The GCS says /usr/local/info; the FHS says +# /usr/local/share/info. Many distros obey the FHS, but people who +# installed their emacs from source probably have a GCS-ish file +# hierarchy. +infodir=/usr/local/info + +# What command to use to install info file(s) +INSTALL_CMD=install -m 644 + +# Info files generated here. +infofiles=slime.info + +TEXI = slime.texi contributors.texi + +all: slime.info slime.pdf html/index.html + +slime.dvi: $(TEXI) + texi2dvi slime.texi + +slime.ps: slime.dvi + dvips -o $@ $< + +slime.info: $(TEXI) + makeinfo $< + +slime.html: $(TEXI) + texi2html $< + +html/index.html: $(TEXI) + makeinfo -o html --html $< + +slime.pdf: $(TEXI) + texi2pdf $< + +install: install-info + +uninstall: uninstall-info + +# Create contributors.texi, a texinfo table listing all known +# contributors of code. +# +# Explicitly includes Eric Marsden (pre-ChangeLog hacker) +# +# The gist of this horror show is that the contributor list is piped +# into texinfo-tabulate.awk with one name per line, sorted +# alphabetically. +# +# Some special-case TeX-escaping of international characters. +contributors.texi: ../ChangeLog Makefile texinfo-tabulate.awk + cat ../ChangeLog | \ + sed -ne '/^[0-9]/{s/^[^ ]* *//; s/ *<.*//; p;}' | \ + sort | \ + uniq -c | \ + sort -nr| \ + sed -e 's/^[^A-Z]*//' | \ + awk -f texinfo-tabulate.awk | \ + sed -e "s/\o341/@'a/g" | \ + sed -e "s/\o355/@'{@dotless{i}}/g" | \ + sed -e "s/\o351/@'e/g" | \ + sed -e "s/\o361/@~n/g" | \ + sed -e 's/\o370/@o{}/g' \ + > $@ + +#.INTERMEDIATE: contributors.texi + +# Debian's install-info wants a --section argument. +section := $(shell grep INFO-DIR-SECTION $(infofiles) | sed 's/INFO-DIR-SECTION //') +install-info: slime.info + mkdir -p $(infodir) + $(INSTALL_CMD) $(infofiles) $(infodir)/$(infofiles) + @if (install-info --version && \ + install-info --version 2>&1 | sed 1q | grep -i -v debian) >/dev/null 2>&1; then \ + echo "install-info --info-dir=$(infodir) $(infodir)/$(infofiles)";\ + install-info --info-dir="$(infodir)" "$(infodir)/$(infofiles)" || :;\ + else \ + echo "install-info --infodir=$(infodir) --section $(section) $(section) $(infodir)/$(infofiles)" && \ + install-info --infodir="$(infodir)" --section $(section) ${section} "$(infodir)/$(infofiles)" || :; fi + +uninstall-info: + @if (install-info --version && \ + install-info --version 2>&1 | sed 1q | grep -i -v debian) >/dev/null 2>&1; then \ + echo "install-info --info-dir=$(infodir) --remove $(infodir)/$(infofiles)";\ + install-info --info-dir="$(infodir)" --remove "$(infodir)/$(infofiles)" || :;\ + else \ + echo "install-info --infodir=$(infodir) --remove $(infodir)/$(infofiles)";\ + install-info --infodir="$(infodir)" --remove "$(infodir)/$(infofiles)" || :; fi + rm -f $(infodir)/$(infofiles) + +clean: + rm -f contributors.texi + rm -f slime.{aux,cp,cps,fn,fns,ky,kys,log,pg,tmp,toc,tp,vr,vrs} + rm -f slime.{info,pdf,dvi,ps,html} + rm -rf html Added: branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.pdf =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.pdf ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.tex =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.tex 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.tex 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,123 @@ +\documentclass[a4paper,10pt]{article} + +\usepackage{textcomp} +\usepackage{fullpage} +\pagestyle{empty} + + +\newcommand{\group}[1]{\bigskip\par\noindent\textbf{\large#1}\medskip} +\newcommand{\subgroup}[1]{\medskip\par\noindent\textbf{#1}\smallskip} +\newcommand{\key}[2]{\par\noindent\textbf{#1}\hfill{#2}} +\newcommand{\meta}[1]{\textlangle{#1}\textrangle} + +\begin{document} + +\twocolumn[\LARGE\centering{SLIME Quick Reference Card}\vskip1cm] + +\group{Getting help in Emacs} + +\key{C-h \meta{key}}{describe function bound to \meta{key}} +\key{C-h b}{list the current key-bindings for the focus buffer} +\key{C-h m}{describe mode} +\key{C-h l}{shows the keys you have pressed} +\key{\meta{key} l}{what starts with \meta{key}} + +\group{Programming} + +\subgroup{Completion} + +\key{M-tab, C-c C-i, C-M-i}{complete symbol} +\key{C-c C-s}{complete form} +\key{C-c M-i}{fuzzy complete symbol} + +\subgroup{Closure} + +\key{C-c C-q}{close parens at point} +\key{C-]}{cl}{close all sexp} + +\subgroup{Indentation} + +\key{C-c M-q}{reindent defun} +\key{C-M-q}{indent sexp} + +\subgroup{Documentation} + +\key{spc}{insert a space, display argument list} +\key{C-c C-d d}{describe symbol} +\key{C-c C-f}{describe function} +\key{C-c C-d a}{apropos search for regexp} +\key{C-c C-d z}{apropos with internal symbols} +\key{C-c C-d p}{apropos in package} +\key{C-c C-d h}{hyperspec lookup} +\key{C-c C-d ~}{format character hyperspec lookup} + + +\subgroup{Cross reference} + +\key{C-c C-w c}{show function callers} +\key{C-c C-w r}{show references to global variable} +\key{C-c C-w b}{show bindings of a global variable} +\key{C-c C-w s}{show assignments to a global variable} +\key{C-c C-w m}{show expansions of a macro} +\key{C-c \textless}{list callers of a function} +\key{C-c \textgreater}{list callees of a function} + +\subgroup{Finding definitions} + +\key{M-.}{edit definition} +\key{M-, or M-*}{pop definition stack} +\key{C-x 4 .}{edit definition in other window} +\key{C-x 5 .}{edit definition in other frame} + +\newpage + +\subgroup{Macro expansion commands} + +\key{C-c C-m or C-c RET}{macroexpand-1} +\key{C-c C-m}{macroexpand-all} +\key{C-c C-t}{toggle tracing of the function at point} + +\subgroup{Disassembly} + +\key{C-c M-d}{disassemble function definition} + +\group{Compilation} + +\key{C-c C-c}{compile defun} +\key{C-c C-y}{call defun} +\key{C-c C-k}{compile and load file} +\key{C-c M-k}{compile file} +\key{C-c C-l}{load file} +\key{C-c C-z}{switch to output buffer} +\key{M-n}{next note} +\key{M-p}{previous note} +\key{C-c M-c}{remove notes} + +\group{Evaluation} + +\key{C-M-x}{eval defun} +\key{C-x C-e}{eval last expression} +\key{C-c C-p}{eval \& pretty print last expression} +\key{C-c C-r}{eval region} +\key{C-x M-e}{eval last expression, display output} +\key{C-c :}{interactive eval} +\key{C-c E}{edit value} +\key{C-c C-u}{undefine function} + +\group{Abort/Recovery} + +\key{C-c C-b}{interrupt (send SIGINT)} +\key{C-c \~}{sync the current package and working directory} +\key{C-c M-p}{set package in REPL} + +\group{Inspector} + +\key{C-c I}{inspect (from minibuffer)} +\key{ret}{operate on point} +\key{d}{describe} +\key{l}{pop} +\key{n}{next} +\key{q}{quit} +\key{M-ret}{copy down} + +\end{document} Added: branches/trunk-reorg/thirdparty/slime/doc/slime-small.eps =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/slime-small.eps 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/slime-small.eps 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,995 @@ +%!PS-Adobe-3.0 EPSF-3.0 +%%Creator: GIMP PostScript file plugin V 1.17 by Peter Kirchgessner +%%Title: slime-small.eps +%%CreationDate: Tue Nov 14 18:44:25 2006 +%%DocumentData: Clean7Bit +%%LanguageLevel: 2 +%%Pages: 1 +%%BoundingBox: 0 0 252 104 +%%EndComments +%%BeginProlog +% Use own dictionary to avoid conflicts +10 dict begin +%%EndProlog +%%Page: 1 1 +% Translate for offset +0 0 translate +% Translate to begin of first scanline +0 103.29540259080517 translate +251.14960629921259 -103.29540259080517 scale +% Image geometry +248 102 8 +% Transformation matrix +[ 248 0 0 102 0 0 ] +% Strings to hold RGB-samples per scanline +/rstr 248 string def +/gstr 248 string def +/bstr 248 string def +{currentfile /ASCII85Decode filter /RunLengthDecode filter rstr readstring pop} +{currentfile /ASCII85Decode filter /RunLengthDecode filter gstr readstring pop} +{currentfile /ASCII85Decode filter /RunLengthDecode filter bstr readstring pop} +true 3 +%%BeginData: 57552 ASCII Bytes +colorimage +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcDnQp&=1TJ,~> +JcDnQp&=1TJ,~> +JcDnQp&=1TJ,~> +JcE=]rVd0(rr2loqtg-`p\+IV#PRoeq>:*grpKf:~> +JcE=]rVd0(rr2loqtg-`p\+IV#PRoeq>:*grpKf:~> +JcE=]rVd0(rr2loqtg-`p\+IV#PRoeq>:*grpKf:~> +^&S*2K`;\ar;-0]p@n@Wp@RnBl/gp^gtM_[%,0ImiT04hnFZMQrVl?eJ,~> +^&S*2K`;\ar;-0]p@n@Wp@RnBl/gp^gtM_[%,0ImiT04hnFZMQrVl?eJ,~> +^&S*2K`;\ar;-0]p@n@Wp@RnBl/gp^gtM_[%,0ImiT04hnFZMQrVl?eJ,~> +_#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=<e0hVR5Pj58P;ahkZtYGnAsUCF&u +Xg>RRajSr)m.C/Qo)F4~> +_#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=<e0hVR5Pj58P;ahkZtYGnAsUCF&u +Xg>RRajSr)m.C/Qo)F4~> +_#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=<e0hVR5Pj58P;ahkZtYGnAsUCF&u +Xg>RRajSr)m.C/Qo)F4~> +_>al?q!dM,hr<khq#'=Ts8E&tr;?HlqY^3lr;HTmrp0RjrquQ`naQ,CqYg!b$NBttna#E'me-GU +p&>['q!?_R[B6U<\@8]>TW+a/a2[rL%+WD>YGn1p]$&prp\j^`J,~> +_>al?q!dM,hr<khq#'=Ts8E&tr;?HlqY^3lr;HTmrp0RjrquQ`naQ,CqYg!b$NBttna#E'me-GU +p&>['q!?_R[B6U<\@8]>SYMdk^:j@0%*ZE"VkT`^]$&prp\j^`J,~> +_>al?q!dM,hr<khq#'=Ts8E&tr;?HlqY^3lr;HTmrp0RjrquQ`naQ,CqYg!b$NBttna#E'me-GU +p&>['q!?_R[B6U<\@8]>V6mGObffhD%+WSI]!S?7]$&prp\j^`J,~> +h>[WWrVZQgrV-NkqY^<ko`#?tp?:)F[BI!Uf')i*lMh(eqtTjUnF$;Brp0RM%di]RoCV_Lp\=R\ +qu$Elo)B*rq=<_'da6P&m.UALrs\o'o&\EB_8O^YmeHbTrs\o'mFAPViU?6RSZ0Nnmg%djUU8G5 +p\jaaJ,~> +h>[WWrVZQgrV-NkqY^<ko`#?tp?:)F[BI!Uf')i*lMh(eqtTjUnF$;Brp0RM%di]RoCV_Lp\=R\ +qu$Elo)B*rq=<_'da6P&m.UALrs\o'o&\EB_8O^YmeHbTrs\o'mFAPNg$@t9Q_M(XlNc+VT=!#1 +p\jaaJ,~> +h>[WWrVZQgrV-NkqY^<ko`#?tp?:)F[BI!Uf')i*lMh(eqtTjUnF$;Brp0RM%di]RoCV_Lp\=R\ +qu$Elo)B*rq=<_'da6P&m.UALrs\o'o&\EB_8O^YmeHbTrrrDumFAP[rlbJ^Vm=2*bQc%f[*e.4 +rUg,?~> +i;XMjrVH<]nEfB#j5]4`lgOH>q>C3jq>Us'pZTo*]]&><]WTQDp\jIY$N0Yek2"S6bK.`Erl4rX +&]r8De_&U3i8`tbmIBiCqYgEerser%mFoFYYH=n8d,t$!pAYX%qXE=XWP-?nW4LRHq>U0h%/ohS +[aX<je^`UCkMY^W#he/'d]LsbqYp0fJ,~> +i;XMjrVH<]nEfB#j5]4`lgOH>q>C3jq>Us'pZTo'Ze=ZtZ`DC8p\jIY$N0Yek2"S6bK.`Erl4rX +&]r8De_&U3i8`tbmIBiCqYgEerser%mFoFYWMcZ'd,t$!pAYX%qXE=XVR4(PUUo%Cq>U0h%/ohS +[`n%#kND*rlfmd!#jCO?bH'(YqYp0fJ,~> +i;XMjrVH<]nEfB#j5]4`lgOH>q>C3jq>UWspZTo0_>_X^_6_GNp\jIY$N0Yek2"S6bK.`Erl4rX +&]r8De_&U3i8`tbmIBiCqYgEerser%mFoFY\[SrTd,t$!pAYX%qXE=XXhr)uZ+ANQq>U0h%/ohS +[`cFp[C*Zc_S#6C#e.Ieb-TO`qYp0fJ,~> +ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=YujOr):jPR)inGDVQ#lOAYeA&,YUT+6j +rMKRl&ZM@nU8Fur\%T]%dFmOFo_SR^rt#,*mFJYMn*93*d]1LSp\jjd&,YqR];b5Zi8F"CZIeRB +rqZR'qsDY1lH-<4XLlTm]<(D##dM"dh:&pnpAO[aJ,~> +ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=SolKIEplJ&AinGDVQ#lOAYeA&,YT;)+R +&tu(iSt`*_Z+%Eab0eo%lh(&Qq#:m(qX)k@WpB$<mE;ENkkG&Mrt#"th7KHKlKRR#^9ZAZqu6Ek% +/]G:VsNL&hr!DRj5K@^#iO\'l-$WrpAO[aJ,~> +ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=kd^ULV[^W<b3nGDVQ$iK\\eA&,YXL#19 +Yl1d*YS+4IURn3WX0K.I_ogB[ip675rqQL(rqc$5[(=K"`5g$'bNS^!p\td$o%gpab.kU%a2YF: +n,*+[rsekmc*tWnTq@sSXfJ=km@FTWVQdYS\`*8\p&BO~> +jSp5!r:odDfu^e(TW#$4`5KX*VPBrn_U.-&nbE%]rr3Q/q<,T+jM8%%Z,#G4_<:Xnn,E[lpZKc$ +a7&Kap$)PFrpL<S_o0']WM$/ubMVgcrqZR)r:8UMa62!paj&Z!WmpM7q#:p(p>j&hlI!DZ]?TEJ +]]&S_qYq$(q<,Q6i4G)-M3+3lOR.f0N0'^WmB"n/r:U)?~> +jSoYfr:odDfu^e(SYE!prk&ZETV&$d_U.-&nbE%]rr3Q/q<,T#lJgaZi8X%._<:Xnn,E[lpZKc" +^?b+Po^)SC%GA>*Yb%S[Vmjk,nG<.[rt#%ugU4c]kN(^cl.W)cn,)n[&H2=`_5$AZio/kXlE\(] +pAOjf%K?1d^qT'lg=Os1gtUQLf*L$_h<"%&f(&\2s*t~> +jSoYfr:odDfu^e(V6RMKrko5ZYH4P+_U.-&nbE%]rr3Q/q<,T1^SmiuTr>`A_<:Xnn,E[lpZKc* +`luZIou$jQrQG\e`4`=ZUo1]FhsgLAq>V!'o%URl_R6MJYe%o[eF3;0rt,/&jMA1@ZDaXtYeRud +iV*6Hrso&(kJ5*MVO*gCQ^<u(SF)jQS!TSJa0jLgr:U)?~> +jo5bfq=3Rs^o=!Gi9omnrSSgZlL"&YYFr&9f&uZ$rr<#tp><.DeZ=^dN2tLtZ/>9Sn,E[jn'nDq +i76B&ouR3]rm_J2i8E\]lL+,hXhEQ]r;-F*rqPZpWTqU,S"$+djLMq`p\t!g&GtqFVs_s0PE:m' +dI*aUmeck\%0$%_\AdC<OF21uK7NrKs+:9-!/p]8re^Z,$@I,DJssdGY0lb:p&BO~> +jo5bfq=3Rs^o<g:g$J(krTPHim-X,NVk(!.f&uZ$rr<#tp><.@kMOqDf\blXZ/>9Sn,E[jn'n>j +l0%6kp#H,8roXCIl07L4liue!VnLpWr;-F*rqPZpU?psugt^`FlE\(_p\t!g#5dl<V!R7#rn7S5 +k3Sbfmeck\%0$%_\@h(bg="<qeC4EFs4%)#!8./%rn%2"$I[>KeD0-OVpY#3p&BO~> +jo5bfq=3Rs^o=9Obf[l@rOa8f`5g*>\>6:Ff&uZ$rr<#tp><.![@`qYS"@%3Z/>9Sn,E[jn'nV` +]X>/OorS5"rj<3E]Y)"t`6-<H\%UVgr;-F*rqPZpZc&u<Q^=/>^V@GAp\t!g&GtqFXNIi=QC!r. +ZH9&lmeck\%0$%_\AZ%WQ`IKoUS[sjs.fUb!1WhPrgj(a$EL>7UR/+$\'a^Cp&BO~> +kPl%kr:]F/_5=EomGQ[Fai+.i+Mc+De_oWYdBTXhhspRBs8DWFVsi0;M04ZUeaKEjp&4C[$3'b_ +^rPBFXK8,gRfK>bX:DMI]>2P1dFI(<^;T1/rql^-r:8L?i7YAoK7f#]eaK<anbi7`')q^i^q/UB +PC(a)n.P/$(f]]Akequ7B0pYrX"i4G(uBk_L(Jr,SXR]EKoqRZ[,s-a:VNerU]aQg"Znbi([J,~> +kPl%kr:]F/_5=0amHNisjQ$3t+QDJDkNV=!af25XhspRBs8DWFVsEO'f?`(+kNf&#p&4C[$3'b_ +^q]-mhr!8_g]641h[\T'iSrqZk3)!q[`%>'rql^-r:8L?g$%AHeC<+-kNeqonbi7`')q^i^p<7b +g=+Kug>_D&]]Akequ7B0pYrWol/C@Eb0%rPeCWF0gu%#IqVhG2s4dt8g"4j2jQrnrnbi([J,~> +kPl%kr:]F/_5=`da1SmeXfMDt+K2EH[CjB!agn@hhspRBs8DWFVp)Q@S@"iY[EPQ'p&4C[$3'b_ +^rO*bT:_SFQN3QTT+7QlVPpW!ZF.9^_o1^4rql^-r:8L?bdX:8USFBO[EPGsnbi7`')q^i^qd^` +QDgj_QDhR4]]Akequ7B0pYrX!]V_$raiV93URdd=Q_'eBqPO7`s-F([R(a)Tn8Xi.d"nbi([J,~> +kl21mqXW[jYG^=Ag!..6VONkLO<BaVTrblEdG=!DXM<]cr;Z`ffq\#dXGM(VX4?[6g%>74rsA]! +iNr"'XGMdfon*7"reV,DOH>ZqS#39qeaKToo_n^f'E7jn`i87FRtGWtJssdGVoS*!rql^.rUo!M +dG;6kH>.S]Z.\'7g%51>rtPJ-j0lna]9%DS>]54_X1HBne^`@Li;V:,a9oMeX/ii!jIG&urUp2@~> +kl21mqXW[jYFsS7kiLd]hV?l`g)o,+hr3VXl0I$"^Ynb^s8DTCU[.+#f?`(+kNenro_n:Z$3'\X +Zg6f3f@SRGe,\)!f)XJ&gAfq6hV[;Tl`Ak5rVZ[/rqbp"U?psreBH.dguRgqa6NO#qu7<-p"cgo +l/C=Cb0\f!kh2rgoDSRd'`Rmf[_1k`g="-?bgbG*iT0(_kNMd,roa=Bs5F"8#3"t'QJM33p&BO~> +kl21mqXW[jYHc<g\$2a'S<oN>QQVT\R\-IXZF[os[D1Ylr;Z`ffqZd!T:E9ZT!ce;g%>74rsA]! +iNpb9T:DFFoqMMYrgXIfQ^=#)Q^j\C[EP`,o_n^f'E7jn`j3ObQ_V:/UR/+$YfH&*rql^.rUo!M +ah"78Y0!r<Tsr7Fg%51>rtPJ-j0ln=VO+@*`4r(6Su/Wl[C*L?]`,>=XU:r#St;h"fsBN,rUp2@~> +l2M=oqXE=XUVuHN`3H"tN/*%9rHo`:K8#/DQ);".g$5``lh^VZo[oo,eZ=UMM6#1qU=f,:nG`am +pY`=FeZ=W(K)0BuF*2bUG^OmfK7er9R`Octe+*A6rtGA)i3^G\]9%DSBRGoQi5E+ap\t'i')_:K +TC:=3M03<JKqQ]XUWr6(qu7W7puK!)i4G(uBlATlaOT56lL43!_SEt)_na(en,MY[i8)r6i9cK, +lM:GPs*t~> +l2M=oqXE=XTtKaUj5AbIf[eR$rR)h;eCE1)gYUoLkj57klh^VZo[oo(kMOn;fAGcWU=f,:nG`am +pY`=BkMOnfeG@B%cHjndd*g@keC<($guRh$e+*A6rtGA)i3^/]iS)`&ajSo%l+FLbp\t'i')_:K +TBk[tf?_"Pe_T?ST?Zg$qu7W7puJuul/C@Eb08AjjQGdom-Euj]!f)[]=,0Ili6;Yl0.<nl0Wu" +lM:GPs*t~> +l2M=oqXE=XWPl`aX.buKS"?COrMq'>US43EQ(4VM\&>c!lh^VZo[on^[@`trSY!75U=f,:nG`am +pY`=#[@`ucU\_\;\$W<=Z)aq(USFENQ`\3:e+*A6rtGA)i3^G8VO+@*b,^o,]Yh5<p\t'i')_:K +T?O^8S@$>KTpi4+XNg21qu79-puK!(]V_$rahOU;XgPg[`;[sb_8jX6_T0^rbl>Tg]XkMY]Z7S& +lM:GPs*t~> +lMhLrq<ltJU#+_LZ'C9%I!BpeJqs>^+GGDrH$k-tNg6m"n%.TTrr)KAU@6X6M04ZUeaK6bo_n:Z +#QFM[][>QDT_b)XJoCQl!b$#!r/(B(#,]f9YL;q<r;RH.n^X?%eZ=UM(a)q9eAZ.\'6g%>7?rtG7p +aJ\=FRtGWaCk.ehkH;Ybq>U<l.fT8,^8^;6Q%3e)R`Od-_ip@!CNQauDmZliDJX'$Q(l+An*e,M +I_bURo`'F~> +lMhLrq<ltJSD*5gi7lo7da6CjeCOWN+P"uidF-Lpg"YHJlal0Prr)KAU?h""f?`(+kNekpo_n:Z +#QFM[]ZKEsh>5n-eBIif!jg,#r7Cns#2\M/WRC;6r;RH.n^X?!kMOn;\\?GCi98jmg%>7?rtG7p +aJ%t]gsjQFbL>5+l__M^q>U<l.fT8,^7X`OgXFBrguRh/]7l#@=_+^A?F7(F>Zt61LRbiolg)'+ +DS#K<o`'F~> +lMhLrq<ltJWQ2ZRTp;+@X0Jh)US%OV+JGR/Y,eCjR?aJRbdum1rr)KAU<L$;S@"iY[EPAto_n:Z +#QFM[]Zds^Rei?OUV?ZF!li!Mr13e]#+W!(a)]$g*Gr;RH.n^X>W[@`tra2kNTTsr7Eg%>7?rtG7p +aK`[cQ_V:6_PWU!_RIAFq>U<l(]O6n^:M1^Q)26jQ`\3B_RmL`Yd(C=[JmNDZa$a:]rT5tbfn2@ +]@Z]Qo`'F~> +li.Xtq<lnDVsVmDRuDlBF+/n$Q("TLX!"((P)bBSJqBZ,i:488p\t-`fV7ibXGM(VX4?[5f_#.2 +rs&>ecA:l@c2,KfRt>Q`91rN.JsuV<rL*qfdI*[[oDSUe'Dh%9W9VKoK5Y"&F,-X?m[qkpr;?R/ +rqPQc\E(GhIVW)"I#tqt_mSLurqudGrqblrS*J+bK7]Q5lAK2SF*;eSL>RB+iSf03H[9p[_/X@p +DfU)Zc27M4s*t~> +li.Xtq<lnDT^Cn#gt:*&cI1:qgYCZbh]Ub1g=b*/eC<=5l0>_:p\t-`fV7]phq-3+hrj="f_#.2 +rs&>ec?\g(a)jne$EgsjQEBP=6deD0uZrS.V6k3SPhoDSUe'Dh%9U?psreBFepcIUk7m$uGkr;?R/ +rqPQcYNk-$e'"0$db<[E]X?bnrqudGrqblrOmM/aeC<:7m!_j6@:Wt`G2I%MiSeNdBkV*h_-^HL +?!q8ia8>l.s*t~> +li.Xtq<lnDYfF&HQ^ahV\>Z$jQ'\$?SfjJgQC4;9USF9T][XCLp\t-`fV6TtT:E9ZT!ce:f_#.2 +rs&>ecF_-+YkkI.Q_V:5]tMA!UR1nMrKd_YZH9E)oDSUe'Dh%9Z,Ec2UV=^e\=]:saeR5Or;?R/ +rqPQc]t^M3W5ZZsX-fcs_mSLurqudGrqblr[)B)5USF0X`3cMF\@]Gh_r&;IiShVh^q[Rp_7$_Q +[(!`gjSSrKs*t~> +m/Ie!qXE4IV<Z=&OFqdrIYWcWX2N*,rm`.9aM50aVOEsH]'dSQk5##To[oo,eZ=UMM6#1qU=f,: +n,EUjp#:(\iU-L,$-AZgDd6OcJssdYec!PndFH75jS/ZPrtYP.jh&%`^ls4_=^5lsR`Ocj`9R3u +rVmT1p"Z[sh6r>iB2rJdMm:snWnd:Gqu7Q1lG]=Zad[p7R`OcVDUX#aJV&sWK7ipmKDpH1JUls4 +I,97"J<87ZoDa=~> +m/Ie!qXE4ITBt[rg=4Kndam%,hrEe[roYEcjPo.UhV?oBiU".jk5##To[oo(kMOn;fAGcWU=f,: +n,EUjp#9G<g?nb'$09mkbbh5\eD0-_kPaHGk3'LOjS/ZPrtYP.jh%_]inDl)RAJ-WguRgo`9R3u +rVmT1p"Z[ll/C=C`JhOXf\kuHWnd:Gqu8)@lG\tRjP887guRgS>gmJ+DfC7$EH1aIEH,r:Df4cS +C>N]ADLg"2oDa=~> +m/Ie!qXE4IYJdZ8Q_Uh#W1TWNSu]!!rj<lQXf/"dS<oS2VTI6#k5##To[on^[@`trSY!75U=f,: +n,EUjp#<NtbfBRu$*BPh^;Rt)UR/+\[Jd33ZF.Q_jS/ZPrtYP.jh&4@W0XC$_o0<bQ`\3/`9R3u +rVmT1p"Z[k\tb[rahc''S"[=8Wnd:Gqu8)@lG^0LXd>fXQ`\3:ZdZe1`lH?uaN4,MaN2EB`l7/Y +_;<#G`Qd]IoDa=~> +m/IdtoA@0XlH,`THuEqGM5I?$e`Z5crpLuslK$dOdE'DRea@b2med"^o[oo,eZ=UMM6#1qU=f,: +n,F7(qso,XGH%U-Pbt7>Q)D`nK5Y[[R`NR_rU9^M"n&Y&\FBCnrtYM*hQG8^[Z5ZH<E<d\OLjAg +\`EPbrVmT0n^F)ueZ=UM@o6]XM6#1qT[iW3qu73'lc,L\ad[p7R`OcYF6%rPKE[S=Kn]O*re:?) +#l91+p4J!NP1K4(J,~> +m/IdtoA@0Qm,[!Rd`fq]fA>EIkNhL$rp(]om-<ftk2bUbkNlp1med"^o[oo(kMOn;fAGcWU=f,: +n,F7(qsnN5B;D;XL7b&iO.YLgeBH.dguQG\rTjCJ"K/W4nGE.`(&dg^Y0-"fg!RctOic&*iT\"c +jS8`QrtPD$e"5mghq-2bI^m_Uhrj<ueai\9rttUu`focMgsjj/jQqS/jD]-[F+aI5F8l1;F8p7d +qJgNKEH-#Od.73e~> +m/IdtoA@0a`3#K"X1l?USXc:W[DKl(rlcM*`4rmkZE:75[E5l)med"^o[on^[@`trSY!75U=f,: +n,F7(qsqV9['?sN]W\HKT!b\eUV=L<Q`\!;rQP5Y"j+Tfd.$r1rtYM*hQFu3URA:,_8=?qR&7O7 +\`EPbrVmT0n^F)R[@`tra1o[%SY!75T[iW3qu7N0lc-BOXd>fXQ`\3<\E(]Pai`!0b0'__rQ>/^ +#l;W`p;k=sd-^E(J,~> +mJf3GpufYlmEM>YF(oQ8M6#%Sma%ntS"+2]Kp9'nn*]K+mGF7PjS&QPrUea:n("LrFc!0Ln"SJ, +rU0\3rqh:sLXXIiFiM79Q&Y(NRtH<]aQe[mBPM7MQBd`$HZRi\q>U<l(&d^SU@6X6M03<*<+^E9 +[b]?6hY-sIrtP=qa/A4ERtGWa9jVgnTZukucL:Z-rt"tl`guD:RtH<]aQf"3l(a)f.j"dAt?L&_2M +K`h@/L&V(*!L)+*s*t~> +mJe4+pufYhmH*0ScH=AWfAG`Rm)YrVR@I?IG(m-?li-5fmFmD,jS&QPrUea:lf[0Wce%(;l_<&( +rU0\3rqgYOGLOcGA&c>kQ%//]gsjj/jQq=l<`iImLkgbBC15c3q>U<l(&d^SU?h""f?_!VMT!oq +iTSCdhY-sIrtP=qa.Ve[gsjQFDQD%4h<"$qcL:Z-rt"tl`focMgsjj/jQqV2l>llF"bZhrF8u:; +Es)G`F8l/[!JAbis*t~> +mJf3GpufYta0;#+\&lClSY!-paiCa#Tq&9S\@]DsbfRfAa3)0.jS&QPrUea:bdF(5[%3erbbEb^ +rU0\3rqjaS`7)rA]#MRoQ*nQ4Q_U=BXi.TFXfnps^:h4p\%()Kq>U<l(&d^SU<L$;S@$>O_9&jJ +UUnOLhY-sIrtP=qa0ERbQ_V:6]u@UWR]si4cL:Z-rt"tl`jWgfQ_U=BXi.l`lH0%J"jm:lb5_M= +aoh[db5VC_!RU6)s*t~> +mJf3DnC=Jqfs-K\AT)sQX4?XAG&4^3cI7'eG'(<5CNukFWNp\qoDARfrUea:n("LrFc!0Ln"SJ, +rU'V0re,obna:pXlK*8mYiNT`IY+$0lB,q,H$Rh^G'8(UIdkeaqu7E.m`hKnc(Ti2?VO@+Fc!0L +n"\M+rVlg3rqGKa\E(GhIVW(Z>]54_aQfYBlh^MY&,PV3Sa+=dK7]Q5lBHGWK`6Z/PQ->js8VtM +"94(/s8I]QPLf=)J,~> +mJf3DnC=Jjkht+?^Wb-Xhrj@&AQlWScI6FSAR`5U=_FOdV6XWIoDARfrUea:lf[0Wce%(;l_<&( +rU'V0rc<(0na::4lK)Z\V<['oe(!16m"8PRB4oY(A7T7bD",[Iqu7E.m`h?jjk\J3XDiQsce%(; +l_E)'rVlg3rqGKaYNk-$e'".kV9IHEjQrPZlh^MY&,PV3PO.AceC<:7m"T$9ErL+`KE$"6s8Vt; +"93F`s8I'?K@'2hJ,~> +mJf3DnC=J]\"T:raM4dHT!c\TZ*LpOcI9MU]XbV[YdCdOZ*M!YoDARfrUea:bdF(5[%3erbbEb^ +rU'V0rlW=,na=B8lK,a^`4r7:W2#]]`4<4d^:r%.]=Y_j_slphqu7E.m`hfQYaV8s`P0+-[%3er +bbNe]rVlg3rqGKa]t^M3W5ZZe`4r(6Xi.E_lh^MY&,PV3[`#;7USF0X`4W\Iao9Edd/V82s8Vu= +"96Nds8L.Ad-^E(J,~> +mf,?IpZ9/nkJWX9D/Xf`X4=@sDfpBeJ+)r[nUQ,NI!U%_GLYK!K)>QIs8DTBU@6X6M04ZUeaK6b +o_n.Vs+M8Pr;2/#q=B!@_;MqeI"e6<m?D^@JV!@iJ-1CUqpkTD(B40p_klY?RtGWa928l9LSiJe +S^6d&rr3c4o\-=lh6r>iB2qN,Ck.ehkH)G]q>U<l&,PV3Sa+=dK7]Q5lBHGWK`6Z/PQ->js8VtM +"94(/s8I]QPLf=)J,~> +mf,?IpZ9/glf6aKbfnMhhrgeI?"@X0D=@%7nSW4*C1q5)A^oRRE;TY7s8DTBU?h""f?`(+kNekp +o_n.Vs)T97r;1MTq=A@.\*;l*dad18m=o(cDf>/aDJjB3EVn)ZrtbV1l,0+ZjP88/VJ(+WcIUk7 +m$c8hr;Q^3rUegDam%d;dD_&OT$,U;j6NPVkP>,Trt"tl`focMgsjj/jQqV2lZ2uG"bZhrF8u:; +Es)G`F8u5\!JAbis*t~> +mf,?IpZ90"_Q/ru_S<.=T!c;<[(F*6`:*9;n\rH._8!\/][YfVa8>l9s8DTBU<L$;S@"iY[EPAt +o_n.Vs2lG1r;4UXq=DG0aLnC:X.buda1]%#`l@Pg`Poj;aSYB%rtbV1l,0[BXd>fs`P'"*\=]:s +aeI,Mr;Q^3rUegDah"78Y0"Mm_nr:9X2;9ZkP>,Trt"tl`jWgfQ_U=BXi.l`lcK.K"jm:lb5_M= +aoh[db5_I`!RU6)s*t~> +mf+X3o%0etfs-K\Dg[YXeW=TiH[gYBK`(e%r.KauJqARBJFW;bK`:uN&H27RU@6X6M04ZUeaK6b +o_n.Vs+M8Qs8Re,rqCiK_;MqeI"e6<m=oh8KS9:$KE?l-f),I_rqPQb`Se@iHtcYO93cCeR`Ock +`p<L#rtbM#c_'XQVMB5$:IS;tI#tqt`4+e%rqud,qWc%jlH,NJJssdGP]c;Fre1N>s+Q1,s8.KP +s+Q1,re1B:f(/ik~> +mf+X3o%0emkht+?bgP5(kCZrJBl.haEr>lWr,QiQEH#jbDt3L?F8l1=&H27RU?h""f?`(+kNekp +o_n.Vs)T!/s8R.]rqC39\*;l*dad18m<<,ZEcV*VErU1]s3UZC(B4*i\\.1cg="-,;J)cLeD0-O +T>p3nrr3c2n'@Njk2+\7ZZf6.ajSo%l+FLcq#:3k&,PS1PO.AceC<:7m"T$9ErL+`KE$"6s8Vt; +"93F`s8I'?K@'2hJ,~> +mf+X3o%0e`\"T:r^T3a![C*<O^r4:gao)+[r5m(UaN)<h`pr`Cb5VD?&H27RU<L$;S@"iY[EPAt +o_n.Vs2l/)s8U6arqF:;aLnC:X.buda18k%aiXJZaoBKas6]^`(B4*i\\u.XQ`J6F]"GtrUR/+$ +YK#o)rr3c2n'@fPZCIMq`kK%$b,^o,]Yh5=q#:3k&,PS1[D]26USF0X`4W\Iao9Edd/V82s8Vu= +"96Nds8L.Ad-^E(J,~> +mf+U0lc?'jad[p$I#tqtNbs#iJqSgVL&_1,s+Q1,KnP-WK`(h'L&M#_rUea:n("LrFc!0Ln"SJ, +rTsRaKbosQs+Q1+pO'9_i4G(uM6#1qBR#)]L&_%(!WUaJs"OHGhQOiT]9%DS=%5\^C4;>\jLDnc +q>UEnq<,SskJWX9D-KS#<bQlB]&:H/htI'Jrt,2+l,0%Vad[p7R`OcYFmF_[Ka!\?Kn]R,qh5.P +Kn]R+K`RCgo)F4~> +mf+U0lc>gejP88/db<[EJQl`&E,p%!F8u8]s)W8]F)uC"Er>oXF8c+MrUea:lf[0Wce%(;l_<&( +rTsRaEu0K/s)W8\pM7(Cl/C@EfAGcW<bH>kF8u,Y!WUODs"OHGhQONTiS)`&P#>DLbL5,(lEIta +q>UEnq<,Sllf6aKbb&<?Oic&*iT[qWhtI'Jrt,2+l,/\NjP887guRgVA*\17Es73rF*%B]qf;l> +F*%B\Ergp?o)F4~> +mf+U0lc?BMXd>fsX-fcsZa.9^a2uL'b5_Las2rLab0%j(ao).\b5M>OrUea:bdF(5[%3erbbEb^ +rTsRaaqrG)s2rL`pVO5W]V_$rSY!75Y.hotb5_@]!WVQas"OHGhQOf/VO+@*_Rd@s`i,3%^V.>C +q>UEnq<,T'_Q/ru_Sj*u_TJpHVS'aKhtI'Jrt,2+l,0pIXd>fXQ`\3=]'IK;ap$/lb0'baqoT$@ +b0'b`aoTlVo)F4~> +n,FF-puK!)i4G(uI#tqtcXh3IJqSf2s+ULQL&Zj\s8I]Us+ULQKn]L*&H27RU$pO5M04ZUeaK6b +o_n.Vs+M8Qs8Re,rq:`C^u2hdI#4oSmqI'!KSBI'K`V5)qu8AKo@Tl-eZ=UM@o5Z`<bQlB]&:K4 +i:m6NrUo'Q_r/.gHtcYO78RH9M6#1qVqUeArVmH.q<,M^lH,NJJssdGP]c;Fre1N>re6()rV_EL +K*_7)KDU=UKp1*Ys*t~> +n,FF-puJuul/C@Edb<[E`Dg;_E,p#@s)\5?F8p<&s8I'Cs)\5?F*%<[&H27RU$Ln!f?`(+kNekp +o_n.Vs)T!/s8R.]rq:*1[cuc)db!C>lW@e=F*%BYErl<fqu8AKo@Tl)kMOn;\UHe?Oic&*iT[t\ +i:m6NrUo'Q]BS;.d`R_N:jfe!fAGcWVqUeArVmH.q<,MSm,ZsOeD0-OL1BOirc86qrc</ZrV^d: +E<GuUEVo`V!JAbis*t~> +n,FF-puK!(]V_$rX-fcsbH&1ka2uKHs2tBAb5]W,s8L.Es2tBAb0'\_&H27RU!0p:S@"iY[EPAt +o_n.Vs2l/)s8U6arq=13aLnC:X.>iibceb$b0'b]aoVP0qu8AKo@Tk_[@`tra1o*p_TJpHVS'dP +i:m6NrUo'Q_n;k5X3&5i]"c:mSY!75VqUeArVmH.q<,N!`3#B$UR/+$]XmFNrlPDkrlWC^rVak< +a924YaSYtZ!RU6)s*t~> +n,FF-p>2t1fs-K\I#tqt^1MM:JqJ`0qh4nGK`6[Zs8I]Us+ULQKn]L*&H24OTC:=3M04ZUeaK9d +o_n.Vs+M8Qs8Re,rq1W<i7YAoG_rKOmqR0#KSBI'K`V5)qu8AJn'@TndAD\?@8BKa;Ik!0Z.\'6 +g@Y@Dr:/7.n("LrF^n9A78RH9M6#1qT%*?/rVn;FpuT-,i4G(uJssdGP]Z)?K7nl=pO\"ho7;FB +Isuk,I=CR8K7oH>o)F4~> +n,FF-p>2t*kht+?db<[EZrCOOE,fo=qf;W5F8g6%s8I'Cs)\5?F*%<[&H24OTBk[tf?`(+kNenr +o_n.Vs)T!/s8R.]rq1!*f]_8Gd+@1<lW@h>F*%BYErl<fqu8AJn'@Kik2+\7ZZeT0K>,^bi98jm +g@Y@Dr:/7.lf[0WcaeL::jfe!fAGcWT%*?/rVn;FpuT-$l/C@EeD0-OL19=cEH6&MpMk0Eo5AMa +D/=%KCM`BWEH?cZo)F4~> +n,FF-p>2sr\"T:rX-fcs`N6Yga2lBEqoSd7b5TQ+s8L.Es2tBAb0'\_&H24OT?O^8S@"iY[EPE! +o_n.Vs2l/)s8U6arq4(,bdX:8Z(7Jobcee%b0'b]aoVP0qu8AJn'@cOZCIMq`kJmm^rWdMTsr7E +g@Y@Dr:/7.bdF(5[)]qo]"c:mSY!75T%*?/rVn;FpuT-,]V_$rUR/+$]Xd4HaN;NKpW1DIo>\bg +`5BLQ_Sbc]aNDlso)F4~> +n,FF,p"QG6eZ=UMF,-X?h/I4SH[^Hom""TrK(X_Jq>Q$Nre:CPKn]L*&H)(IS+"n/M04`]g$klm +p&47Ws+M8Qs8Re,rUkK6n("LrFc!0LmqR0#KSBI'K`V5)qu8AHlc,jfad[p$>Y@sb:h"R(X4?[/ +ddd87qWc%tlH,NJDd5q3787*.KqQ]XU!<$&rVn;FpuAj%i4G(uJssdGPB#B,It)p(iSJq6eTc7[ +FE2B2EHB?NItIULo)F4~> +n,Fa5p"QG2kMOn;cIUk7fO.rqBl%X'lu)=`E:n3jq/ULsrcA,>F*%<[&H)(IS*T7pf?`+-kj,," +p&47Ws)T!/s8R.]rUjm%lf[0Wce%(;lW@h>F*%BYErl<fqu8AHlc,UajP88/VJ&%nI(7MShrj<q +ddd87qWc%mm,ZsObbf'$:i<>Ye_T?SS^$U"rVmE-puAirl/C@EeD0-OKj`^8D&$l4iSJ;$eRi?% +@UWWR?X_/mD/oL#o)F4~> +n,Fa5p"QFh[@`tr\=]:s`iQMZ^r++/m)AJba7[Npq8pb$rlY9@b0'\_&H)(IS'8:4S@"cZ\'Lr* +p&47Ws2l/)s8U6arUmt'bdF(5[%3erbcnk&b0'b]aoVP0qu8AHlc-0IXd>fs`P&[k^W3^PT!ce4 +ddd87qWc&(`3#B$^;[e#]"Q(pTpi4+Wm0u/rVmE-puAj%]V_$rUR/+$]=6Sp`"g20iSMB&e\/T+ +\[])X[^aPs`5qlDo)F4~> +n,Fa5p"QG6eZ=UMA93O'dG9@fDK9iAaEGnYHJ*XmjaVi5q1S_HKn]L*&H)"BU[?="Km\uni8L]k +p&=:W(kn1Rs+Q1*oQm;$eZ=UMM6#1qC3kJbL&_%(!WUaKs"XNJk.J4b^ls4_=[u+a93cCeR`Ocm +amAm&p>NEti4G(uBiePK<_H\9JssdGUr;QprVn;FpYrU!i4G(uJssdGOD;JJFE;K4Z`\,>Sp-Kc +Pc_pC_T/`rGCK;:o)F4~> +n,Fa5p"QG2kMOn;^<Y<dk1O`U>[V#NaCNWGB\@*7j_\pTq/ZH6F*%<[&H)"BTC(are^E11l.N)l +p&=:W(it?0s)W8[oOt#ckMOn;fAGcW=D2YpF8u,Y!WUOEs"XNJk.Iq`inDl)R9F2aAu3`$guRgr +amAm&p>NEll/C@Eb*&U2O_1H6eD0-OT#BpjrVn;FpYrTml/C@EeD0-OJQTV)@prcTZ`[K,SnEk6 +L8DPq\%\_FASq1fo)F4~> +n,Fa5p"QFh[@`traL@e3ZH';S[(!TWaLfdI^Y-E=ji#0Zq8rU8b0'\_&H)"BX2hH5TrXQX][3\6 +p&=:W(s:5*s2rL_oY70F[@`trSY!75YeS6$b5_@]!WVQbs"XNJk.JCBW0XC$_n3Rh]YqR[Q`\33 +amAm&p>NEt]V_$rahl!:_S!h%UR/+$Y/KW%rVn;FpYrTu]V_$rUR/+$\$3Qb]"#5ZZ`^U/T!Z5F +]X>\rai:`q]YsR2o)F4~> +n,Fa6p>2t@eZ=UM@pjA5VU=eg_3:+KVj4$IC8Gcc]6/@Fk(*1&Kn]L*&Gtk;WTqTpK7&cli5)VS +pAXCX(kn1Rs+Q1*oQm8#eZ=UMM6#1qC3kJbL&_%(!WUaKs"aTIi3L8Y]9%DS=%c@_8Qoq\Q,Mje +^ZYCho%'Vpfs-K\AR&nkBNA5MIZhJ,\%Lhtrr2p5rqGBY`8J7hI"Ig.lAAo;Vj*CN`5KOlmf;eT +l2^#Gi!/K*H[+r+rq$/?~> +n,Fa6p>2t<kMOn;\['N3hWF4X[Y0BiTST51=J]5-]45Gek&9tjF*%<[&Gtk;U?psreC*(0l*mkR +pAXCX(it?0s)W8[oOsubkMOn;fAGcW=D2YpF8u,Y!WUOEs"aTIi3KuZiS)`&P%K)R?_5HigZ.Ur +^ZYCho%'Vikht+?^ST&uacVt6db<^GYIrulrr2p5rqGBY]BS;.da[(5m!MKmTSA/t]XtcSli$/M +li$&Pm+H,cmEGS$s*t~> +n,Fa6p>2sr[@`tra2YT\S?g2ZaLf*uZ+d9/YGJP3]=P\kk/R,lb0'\_&Gtk;Zc&u4UT9cZ]Z%)3 +pAXCX(s:5*s2rL_oY7-E[@`trSY!75YeS6$b5_@]!WVQbs"aTIi3L85VO+@*_S!Xr]YhU`Q)hd0 +^ZYCho%'V[\"T:raMc6.b/2'9W0XBs]tEJ%rr2p5rqGBY_n;k5X.u#``3Q/5Z+[ch`5BIkbQ,fb +_uR[Q]EZ=!\@q:orq$/?~> +n,F"!puK'(i4G(uBjP1gLSi>Li;Dj?mJZJ]_8V[aD81>TmXp2lrr3Q+m)Z*iad[p1OLjAdZJbKV +lMhZas8Re,rUbE1n("LrFc!0LmqR0#KSBI'K`V5)r;SPNo@Tqufs-K\AQW2H>YA+2I#tqt_mA:p +q!6%omEM>YEF3C,M0ru;BRGoQi5;n[p\t0l&,u=]ZGYV4OF1tuS&ssamJcANjSn*:eH""raT09X +]*?C5d;e*jrU^&>~> +n,F"!puK&rl/C@Eb,_hnf&#NPl29lJmJZ>Y[_7E.>ean1mW!:Hrr3Q+m)YjdjP885g>V;+ZJbKV +lMhZQs8R.]rUactlf[0Wce%(;lW@h>F*%BYErl<fr;SPNo(a)Tqnkht+?^R1k-V.Yq4db<[E]<gGh +q!6%kmH*0Sc)f%8f@%d'ajSo%l+=:\p\t0l&,u=]ZFfA[g="3pguRhfmJcGPlMg&Ik5aZDj8e6= +i<JB,aC!lIrU^&>~> +n,F"!puK'/]V_$rai29/T:E-p]_o\Ja8O3iaMkj"ZbO35m`<NLrr3Q+m)ZHMXd>f`R&7O8ZJbKV +lMh[Is8U6arUdk!bdF(5[%3erbcnk&b0'b]aoVP0r;SPNo@Tq`\"T:raMYs:`4Wt0X-fcs_R&1o +q!6&#a0;#+]#DgmSZBoMb,^o,]Y_#6p\t0l&,u=]ZGX>PQ`IiqQ`\3Ma8X!W^](nF[/dN3XT5F# +V?X06bdQHlrU^&>~> +mf*jpm*(7Pc(Ti:EGB$*LS:ubr5er`rRLr+*U<(NY'IS+IY.Irs8Vr]`i&+DRtH*M]&:E3iV3?6 +rtC+bo[oo,eZ=UMM6#1qC3kJbL&_()s8N)Mr;SPLn'@TndAD\?@9dDeDd61NGDi`Zi25/to]!Ek +jM6t.CN"T^X,q^BA9Ws:g#/jap&4mi&,u:[YJ];1OF1b\Jt'm4c2Pfb_#CtFX8o-sRfJ`PO9VB& +m>BH;r:Br=~> +mf*jpm*'_Ajk\J7c-*iHf%o9Cr8[k>rTF4Fs6L]XVJ3ThCiK:Ns8Vr]`h;\Zgsjd+iT[kZiV3?6 +rtBJPo[oo(kMOn;fAGcW=D2YpF8u/Zs8N)Gr;SPLn'@Kik2+\7Z_bUdbb]s+d+I:?fr!Emo]!Eb +lJgOHbKSDghqHN$^<kNjkh2rip&4mi&,u:[YI`uWg="-feD0-Jjo4<@ir7p9hZ2O4g]6+-g'6Bp +m<[=%r:Br=~> +mf*jpm**&]YaV8g]>hq$Ssl@Mr2ft'rO)[<*Q6+E[^EZo_oMZRs8Vr]`j!C`Q_UUKVS'pUiV3?6 +rtEQRo[on^[@`trSY!75YeS6$b5_C^s8N)dr;SPLn'@cOZCIMq`l-!+^Vmq/Z(%GrbGNq_o]!Ep +^SmHs`P8I(a)SsZS$aK_5.\'1i+p&4mi&,u:[YJRrLQ`J6BUR/*jYl:a)W;`[nT)bD\QN3<LQNin_ +a1Ts_r:Br=~> +mf*jso\XW*i4kqFKmn5cF+oR7r0m\[rN-%2*Qc^^kO,mVFF<TSrr2c[`i&+DRtH*M]&:E3iV3?6 +rtL1co[oo,eZ=UMM6#1qC3kJbL&_2OL&_/Qf)>V)rqYfrV<Z0lK5Y",H&7,k>[VW.VU=h'cg:)O +VVp.4N-K8gOLhF&OF1bbM6#1qT(a)EH0rr3N.p"ZS*fs-K\AR'/*S#i=_RfJZOOT((:L]2o+JGsp$ +JssdGQdEnQoDa=~> +mf*jso\X#cl/LOPe^DghcILS$r7h;.rSRY6*TZAHlg1mP@qtN0rr2c[`h;\Zgsjd+iT[kZiV3?6 +rtKPQo[oo(kMOn;fAGcW=D2YpF8u:=F8u7?d/Eu#rqYfrT'YOneBFf.dFZmlV6S=shWF0ocg:)O +VV11kf[.jjg>T*kg="-ifAGcWT(a)EH0rr3N.p"ZS#kht+?^ST0(gu$reh#5t+f)XD$e,[tsdKe:W +jQq`M`;K6,J,~> +mf*gro\[+"]Vq9eTr>6.\"T;gQN3KQTDtc/Xg5FQb.ja`_=7=#rqbs#Yf*Z1UT9cZ]Z.>;p\s=T +'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drVn\Qq<>f"`3#B$^;\3sSYNp;`jhY2ZH8iem-`K& +bdX:8Z+m?,VQH__X3.f?T!ce7eFNP:rt#,%goAT-Tpr=.`4i"5T:5bG!1*VNrgWt[rhBIiri6:! +Q`\3@d,Foos*t~> +mf*aqqX/WG_W8tMTTY4eK)U/qK)gW(M>rYXS#3I/dH'5?Eng'ZrVGj"Vs;BnK7&cli5)eZp\s=T +'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)MrVn\Qp>NEti4G(uC2\BXUmcmR>]54_aQfS<jQ=OV +mEM>YEI<kZi.J;HOF2&%TZuktbjPB-rt#)$g8=>hXGM(0;-\$lM1tq]!.Oops)n<g!.b'#reUiJ +c0C\FbP^u3J,~> +mf*aqqX/!#\*E)6h:gN3eGdnoe,\%tfDjPFgtpuLk3CWD@,(/HrVGj"T^:apeC*(0l+"+Zp\s=T +'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)GrVn\Qp>NEll/C@EbKSAebhU^lV9IHEjQrJTjQ=OQ +mH*0Sc-k>)l$'>ig="6rh<"$pbjPB-rt#)$g8=3!hq-2bI\k9<f@BlM!7Uqqs3L\m!7UqsrmqA0 +jm7iQ`Vf?-J,~> +mf*aqqX2)'ahP'TR[0G:U].=lUB%"dSGnipS>!!h^Wa6tg[G";qWl/*`3#B$X-fcs`jF_!roX4p +b5LtbU<L$;S@"iY[EPkia3)R)s8C+?rrDHbs"jZJiO-S9VO+@'^TNurQ_V:5^S@-t`3-u<k/aLA +YaV8sX-fcsWO/OhX1P'oYfEcfmed"`&,l1TVTcH?S@$>O`4i":U&LeeW;`jt[/R*+VZ*@iSHbFb +`4sd\r:Br=~> +mJd^qpj[O*\aA4t^TjH#OH>CuM#`>1K)U-<K85DNVSLmPQ+GfBqYBHsVWu9mK7&cli5)e[p\s=T +'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)MrVo=bo%0_rfs-K\Dg@AOR%p.&DeON[]&:N6g"NpF +jM6t.I#tqtnQ!<]]9%DlR`Oci_Wgprs8W&ifq\#dXGM(0;-\$^H2`3jJcLN(M>iS:Q2[6OWs60& +oPWI0rU^&>~> +mJd^qphaVJZ0gc:io&YJg=k3Wf)XD$eGdl:eCN:,hW!bdLUu=4qYBHsT^:apeC*(0l+"+[p\s=T +'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)GrVo=bo%0_kkht+?bgG,&R&f#lbfS;eiT\"^g"Np= +lJgOHdb<[El9quCiS)`0guRgm_Wgprs8W&ifq[lrhq-2bI\k97dJhSne,\%ufDaJ(g]$"-hZi', +lWi5drU^&>~> +mJd^qpr'kP^;mghW1fZHR$aB(a)SH,;]U].;7URms?S>`p;]t3%jqYBHsYJdQ0UT9cZ]Z.><p\s=T +'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drVo=bo%0_]\"T:r^TO!"V5]fV^<3LDVS'gRg"NpK +^SmHsX-fcse=4FiVO+?YQ`\3._Wgprs8W&ifqZd!T:E:/^VmmoY5YL$UB%"eSc4uVQ2[-LSd)(4 +gp>etrU^&>~> +m/IRoK7A0UL=#>Kg!.UL]!;16!2faa+HVV=HujO_LQf!flD_V\p%[glVWu9mK7&cli5)e[p\s=T +'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)MrVo=`mE;6kc(Ti2H&f>hKr2t]Jo>jkZ.\'2bfcd> +fs-K\JssdG_-N&cad[p1OLjAg\E!A`s8W&ifV7ibXGM(0>]54NNrG.>RK0#[X8][1`;[jWeHXt! +QZ_N>rq$/?~> +m/IRoEG]?tGK9+9kiLmaiSaXk!8d_1+PPN"da$4gf%T'Dm%_DXp%[glT^:apeC*(0l+"+[p\s=T +'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)GrVo=`mE;'fjk\J3dFmLBHCj3QeBH:li98jibfcd7 +kht+?eD0-O\4hD=jP885g>V;/\E!A`s8W&ifV7]phq-2bV9IH@g&B_)g]610hu;R7j8S-=k6C2< +M.>bmrq$/?~> +m/IRoaMbg%\]`%.\$3!3VP3pZ!1a%T+IJRhX1,@1SsH(S`3R5?p%[glYJdQ0UT9cZ]Z.><p\s=T +'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drVo=`mE;NMYaV8sY*l&rV6m@kUV="&Tsr7Abfcd* +\"T:rUR/+$_kXWXXd>f`R&7O6\E!A`s8W&ifV6TtT:E:/`4r(<RJrTQQN3KRT)PSeX8]7#[0F:a +^UiXmrq$/?~> +li.EIK7Mg$DMG[ZmHWWfg&0A#dJh30]!eJtHt[A<IZ1/OhPJTcp$'GllH,NJI#tqt_6r:sroX4p +L&LYrU@6X6M04ZUeaI7!JqSjXs8@ZOrrCXLs$m"_jh7eZ`0GjuNjdd5>E%jhRtGd;VU=h"]==F! +c(Ti2JssdGS7RiJad[p.NjdcjXPNRJs8W&ifV.caXGM(0Dh=FY[f3l;a8jKaec+J,kPjcGmfg[e +F+!T/o)F4~> +li.E8EGjWC>^*F*mHj*%kksTDk5OHAi?$k0d`TeZe(EO>g8!$]p$'Gfm,ZsOdb<[E\@(>jroX4p +F8ba`U?h""f?`(+kNc5`E-$+#s8@$=rrCFFs$cq^jh7MVj4i&1g#;/[97H6ggsjX#hWF0k]==6q +jk\J3eD0-OQ;`J'jP884g#;/:XPNRJs8W&ifV.Wohq-2bbgbG*rSdb:!9O4CrojFKrp9XM"hf1j +C@faAs*t~> +li.F:aMm#I[(3loa2GX'\,<W6ZMpsKVPBZKX3/;gW10<_`i@DPp$'H!`3#B$X-fcs`jOh#roX4p +b5LtbU<L$;S@"iY[EPkia3)R)s8C+?rrDHcs$m"_jh8(=X-KNaRA7@AR'af6Q_V'_S?g8/]==]X +YaV8sUR/+$V5h,FXd>fcRA7@7XPNRJs8W&ifV-NsT:E:/^S@-eU]..iXT5U)[Jmf=_Z%LQbQYtt +\\[n'o)F4~> +li7!=$\\/%HZm!"Um/^2i;E$Dmf)Joi8)elOF1bNCOVG]jLD\VnE7]clH,NJI#tqt_RAM"roX4p +L&LYrU@6X6M04ZUeaI7!JqSjXs8@ZOrrCXLs$ltZgo\u[[Z5ZaQ,Mk5ARFoVXGM(OR`OceV4b6W +^ls4rP/$)KPAFh!eZ=UMM6#1qT[iW2s8W&heXl6[XGM(<Jssd2h>Z@3l2^5Nmgm:N_4m0YQCDZ, +]Q\dTqpk9;J,~> +li7!+$ZblVBk=lTT8'h`g&117llbQVk2G%Bb-T:>g>_D%\)6]<_k-5Ugsjd+iT[k\j7rW9rtKPQ +o[oo(kMOn;fAGcW=D2YpF8u:=F8u7?d/O&7rUemIb3@m<dF6k1lc3"#lf[0Wcd^b2m$X]CXm4p" +e'ct0lKXR:;sWW(f?`(+kNeeko)/OfrU\R2lf[0WccjnojQGb+l2L#LmJcD^]!o/6KnbAP=^8UN +CN'*ro)F4~> +li7"-$H_qY^q@7XXh;`qqof&^rkoql]!A3#X3/H$W0XBs]slngkJOI@Xd>f`R&7O9[c@/^k5Q.< +rUea:bdF(5[%3erbcnk&b0'barQ>0?!:Bdc7fDu7Xi\/LRBEEPX2<2WV9H?>S(a)#&XXi.38TY%t; +QDgaJW5$rJZ)Z$UT:E9ZT!ce8eaiY<s8DQ>T$4U7S@$&+Q`[[,rk/6K!6>)_&&H?.^q7:oS$963 +]Y_\cmIL:-~> +li6s<2#W&YJE5FsFE)5@ChmdZBqD8fTu#(Ci4G(uBjc";VU=h+cfjE(U?]jiK7K6*kJXplq#9FU +'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)Mrr6C(n'RfrdAD\?KqQ]XTl+Jgh6r>iI#tqt_23g5 +eZ=UMKqQ]X\#XO`i7YAoG_Mg8m@_Yiqu?]on^<lpeZ=UMJssdGn'Ake_3:+KUM4MBY&A<#FEMfU +H@4h)JqX-So)F4~> +li6s*2#VE5DWKN]@UNJQ>$4t$=.>q=S%$E(l/C@Eb-B7ChWF0tcfjE(SF#=leC314laaReq#9FU +'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)Grr6C(n'R]mk2+\7e_T?SP[7>0l/C=Cdb<[E\VYt) +kMOn;e_T?SYH)&5g$%AHd+-t6m@2;dqu?]on^<llkMOn;eD0-Olc-NF[tTQlSl]'nY$PID@Uiut +BPQXHEH;'*o)F4~> +li6t,2#YM9`T5ar\[SrOZ*:I+Y+i57WlW?)]V_$rai:i_S?g88cfjE(X2M-,USa<W_TKFMq#9FU +'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drr6C(n'RuSZCIMqTpi4+^oONY\tb[rX-fcs^km]f +[@`trTpi4+^8n`HbI=17Z([Vja/I2Kqu?]on^<lM[@`trUR/+$bf[cCaLf*uX0/\*Y-k^J\[oH% +^VT$NaN=GKo)F4~> +li6s<2#i8_K_Y2kIsud#H[:"iH-j`V^2IeN^Yl_cHtd>EP/$(g^YmtZ`Se@iI"Ig.lD;5Xq>TOV +'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8QW\s8W)ol,0@_ad[p&KqQ]XKQ_1:jM6t.GDi`ZheJ;= +ad[p&KqQ]XT"oMd_r/.gI"7L#kH2M^q>UEkm`hftad[p7R`OcP@;2l`EH?5FcZsikhL'a#It3(> +JqEcNKSBHWo)F4~> +li6s*2#hW<Eqo:UD/=!3BkV23B@+h3^0Xs)[HZZ(d`Tb]g>_D'^YmtZ^$4M0da[(5m$YTNq>TOV +'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8QWVs8W)ol,0+ZjP880e_T?SFCn^QlJgOHd+I:?fP6?2 +jP880e_T?SR_WK>]BS;.daQt2l_VAZq>UEkm`hQojP887guRgM:fsl,?t!PUcY$qGhJ6nCD/O:^ +E,kYnF*%B.o)F4~> +li6t,+TKU,anYMj`5BI1^q[Y9^<k'7^9t24a1S:9X3&A[QDjet&E)EU`Or(7X.u#``4itKq>TOV +'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8QWss8W)ol,0^CXd>fpTpi4+[^36X^SmHsZ(%Grb%dEa +Xd>fpTpi4+VnfsO_n;k5X/;/__R@5Bq>UEkm`i,WXd>fXQ`\34Vm!82\%'#]cb(a)0KhSR.I`5Tad +a2n%tb0'bOo)F4~> +li6s<!<<%P#6+S\KS+o=rdlKhJai)WkBqQiBY`Q<OF1bfNjdckYLhI8`8J7hI"Ig.lB]<OqYoXW +'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8Q*Ms8W)li3UA[]9%DfOLjB?BmjudlH,NJEJ:(1m;TS[ +TnRK8P/$):VU9^0\E(GhIXI6gi5;kXpAP!fm)c3kad[p7R`OcUD0FZ^IXZcsn:?2apAT^DKEM.* +L&V(*!WUaAs*t~> +li6s*!<<%>#6+SXEcH)Lrbs4VDt*13kA"YE<jq8Og="-kg#;/:YLhI8]]nD/da[(5m"rUDqYoXW +'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8Q*Gs8W)li3U&[iS)`.g>V;]=)D<!m,ZsOc.1Y3m;0/k +h:9cug>_DNVU9'aYj16%e'ct/l+=7YpAP!fm)c!gjP887guRgR>@lQ)Ci+$,n8E:=pAT(2EWc5\ +F8l/[!WUO;s*t~> +li6t,!<<&@#6+SkaiMQJrl6AX`piE7kJ=mIY/e2PQ`J62RA7@8YLhI8`4Vt6X.u#``4<bLqYoXW +'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8Q*ds8W)li3U>6VO+?aR&7OGY.D'T`3#B$]:k[ta*G"q +R\@<kQDhRHVU</e]t^M3W2l;_]Y^u3pAP!fm)cNNXd>fXQ`\39ZFnr/_o0L4nA`NApAW/4aTMI` +b5VC_!WVQXs*t~> +li6s<!<<%Ps8N)[re2ebKnY3YK`(_#q1=1VF(X=_Z&EpMM6#1qU!D2o`8J7hI"Ig.lBfKTqW7_k +L&LYrU@6X6M04ZUeaI7!JqSjXs8@ZOs&IYMs8;H=U[Qa7M04?6`95!TJotereZ=UMEJ:(1T$<s_ +EH?o4dI+ERhL0LDlH,NJFc!0Ln"\J)r;QQYa/A4ERtH<]aQet0II`$cq>,dBKS9@(qh51QKn]P\ +rr2uLo)F4~> +li6s*!<<%>s8N)Wrc8'lrc9CaF8YoUq/L?3@T;"Di7QE&fAGcWU!D2o]BS;.da[(5m#&dIqW7_k +F8ba`U?h""f?`(+kNc5`E-$+#s8(a)$=s&IGGs8;H=U[.+#f?_q#j6O-YEb&8;kMOn;c.1Y3RH<8T +c-Fnsk3T+ZhJ6Snm,ZsOce%(;l_E&%r;QQYa.Ve[gsjj/jQqS/C[uK?q>,.0F*%?[qf;o?F*%A& +rr2uFo)F4~> +li6t,!<<&(a)s8N)jrlP5frlQPcb5D.Yq8gS7\Z<r`Tpr<oSY!75U!D2o_n;k5X.u#``4<kPqW7_k +b5LtbU<L$;S@"iY[EPkia3)R)s8C+?s&JIds8;H=UWg-<S@#/YX2<&d^UpYm[@`tr]:k[tT<OcX +]""B&ZH:.uhSQh-`3#B$[%3erbbNb[r;QQYa0<LaQ_U=BXi.i]_XbeCq>/52b0'__qoT'Ab0'b, +rr2uco)F4~> +n,ELhr;-6gKE2#NL&_/QjSji5PQ$7^s+ULQL&Zj[nTo&VjM6t.EJ:(1mA%_LYf,J3OF2YKaQf/4 +lh]`C'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Or;T@cm)ksfc(Ti2KqQ]XUN2*7D9q%HNd>>XKqZbb +KlLLALSiJeHctZ'GFn6MVMB5HTZuktbjG<,qWl/!lH,NJJssdGPf8.JL&V)UL&Zj\s8VtM!rmt. +r;QcJo)F4~> +n,EXlr;-50Ec_6ZF8u7?i;RctKDop<s)\5?F8p<%nRu.&lJgOHc.1Y3m@VGHYe0/Yg="L+jQqfE +lh]`C'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=r;T@cm)kgbjk\J3e_T?SQ=+lK>KH'fg!Rd`e_T?C +e]kAEf&#QUD9M0\AXi&KhU^!&h<"$objG<,qWl.om,ZsOeD0-OL;e$*F8l1CF8p<&s8Vt;!rm=_ +r;QcDo)F4~> +n,EXlr;-62aiaV^b5_JAoDZl4d/M06s2tBAb5]W+n\;BI^SmHs]:k[ta/m>/Yf",NQ`HmJXi.fj +lh]`C'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?r;T@cm)l9IYaV8sTpi4+_RIFsZHKhSRBFZDTpi3S +Tt87RT:E4/Z-2CM]VEWTS=[3`R]si3bjG<,qWl/*`3#B$UR/+$]Z%hbb5VDEb5]W,s8Vu=!rpEc +r;Qcao)F4~> +nc'.!r:faIk^J&6q1OHUs8V0ZK`I>9KdHbQs8RfQKn]8LEKTP.RtGX2R`Ocm_U#F'i4G(uJssdG +R)nXjjo6$KrUea:n("LrFc!0LmqR0#KSBI+rIt4M9)eVI]Xd+=PC@M*TZukXG)CZeZK/fbIVW80 +KqX3??Yk7X`95Tkg@9`?VXN':M04?6`948;kP>)Qlc,jfad[p7R`OcY`ddi=rr3.Us+Q1,s8.KO +s+Q1)rrCX@s*t~> +nc&ppr:faIk\Y3Vq>PI8rrD!VEr^jlF!^j-s8R0?F*%(k?\Ie,gsjQtguRgr_U#Etl/C@EeD0-O +Mob8]jo6$9rUea:lf[0Wce%(;lW@h>F*%B]rH%r;9)eVI]Wg\\g=+<sh<"$IA9r$!VX!0pe'"i; +e_Sd#XNT)Ij6Oiug@9)pVX*F&f?_q#j6NPVkP>)Qlc,UajP887guRgV`bkQnrr3.Cs)W8]s8-j= +s)W8ZrrCF:s*t~> +nc&ppr:faIketH\q>SP:rrDZiaoKffasI)1s8U7Ab0'Iq[^sDZQ_V9iQ`\32_U#F']V_$rUR/+$ +]#a77jo6%;rUea:bdF(5[%3erbcnk&b0'barQ>*=9)eVI]Y;.ZQDhEhR]siB]>qdt`kSI<W5Z`f +Tph[d`PSL;X2</eg@<1tVTcH?S@#/YX2;<[kP>)Qlc-0IXd>fXQ`\3=`l._rrr3/Es2rLas80q? +s2rL^rrDHWs*t~> +nc'-soB+WF^iO[Fl@O\Cs8V0ZK`I>9KdHbQs8RfQKnT/JE09G-RtGX2R`Ock^s/sui4G(uKqQ]X +R*+gnjSonlo[oo,eZ=UMM6#1qU=b'NL&_2OL&M$DrUo!KdG;6kH@1gci:1T.N.5u(mEM>YEF3$l +KlLI-F,-X?m]V!!p@Wg>`8J7hI!h$ei5;eUp&+[P`hr%CRtH<]aQf#0J,4lurrn,VKn]R,qh5+O +Kn]I)!7p`@J,~> +nc'-soB+WF^gUbfl>^ics8V$VEr^jlF!^j-s8R0?F*%%j?\@_+gsjQtguRgp^s/sll/C@Ee_T?S +N6:PbjSonlo[oo(kMOn;fAGcWU=aF+F8u:=F8c,2rUo!Kb3@m<dF-b-l0;DaI;NM<mH*0Sc)e"k +e]k2#cIUk7m&+X\p@W1,]BS;.daHk.l+=1Vp&+[P`h;\Zgsjj/jQqW@D>J>QrrmKDF*%B]qf;i= +F*%9Z!7:<:J,~> +nc'-soB+WF^pq"llH%)is8V]iaoKffasI)1s8U7Ab0'Fp[^j>YQ_V9iQ`\31^s/st]V_$rTpi4+ +]ZTX=jSonlo[on^[@`trSY!75U=dN/b5_M?b5M?4rUo!Kah"78Y,dqe][X1"b/Cp%a0;#+]#DY" +Tt84_\=]:sagnqCp@Z8._n;k5X/hVb]Y^o0p&+[P`im=_Q_U=BXi.ll`;7XUrrpRFb0'baqoT!? +b0'Y^!:B@WJ,~> +nc'-kiPqq)a2=clc$k7ts8V0ZK`I>9KdHbQs8RfQL&18gCp<!9PC@G%R`Ocl^rr^oi4G(uKqQ]X +MU(\gjSoeio[oo,eZ=UMM6#1qU=b(rrr<"P!WRlPs%<4Ze"6$YXGM(MQ,Mk&Dg[UsH#)m!XGM(0 +;-n6L:1/-uVU=h(JaWC0I_`,L`0GjqM6#1qT[`N/qWl/!lH,NJJssdGPfA4LL&V)UL&Zj\s8VtM +!rmt.r;QcJo)F4~> +nc'-kiPqjt^:9S9c"q??s8V$VEr^jlF!^j-s8R0?F8G@U>,:HCg=+9qguRgq^rr^gl/C@Ee_T?S +IEq<ZjSoeio[oo(kMOn;fAGcWU=aG`rr<">!WR6>s%<4Ze"5mghq-3'gZ.V.?#"k-B3FQ`hq-2b +I]UeqFg96ChWF0pEUN\uCquq6j4i&/fAGcWT[`N/qWl.om,ZsOeD0-OL;n*,F8l1CF8p<&s8Vt; +!rm=_r;QcDo)F4~> +nc'-kiPr.7`lc6+c,7TEs8V]iaoKffasI)1s8U7Ab51SWZ,=>TQDhQnQ`\31^rr^o]V_$rTpi4+ +\'FI?jSoeio[on^[@`trSY!75U=dNbrr<#@!WU=@s%<4Ze"4dkT:E9cQ)hdF[)'u+^9GhhT:E:/ +^W!e'^;d[TS?g83^(a)(jm_n`auX-KNgSY!75T[`N/qWl/*`3#B$UR/+$]Z.ndb5VDEb5]W,s8Vu= +!rpEcr;Qcao)F4~> +nc'-^a04poi8EeVW-3ZCrVtsXK`I>9KdHbQs8RfNKC@U-F5>6@LN@BcR`Oco`65"GeZ=UMM6#1q +DU\.Rp&><sr;6?dqYU6jq>V90o[oo,eZ=UMM6#1qU"4elrVc_LL&Qf)s%<.Ra/A4ERtGX5TZul! +F+3lVHuHjZ]9%DS=&!$r>&8_S`95UOL@kE@JBOYRc(Ti2JssdGW6"<#q<Q%ulH,NJJssdGPfA4L +L&V)UL&Zj\s8VtM!rmt.r;QcJo)F4~> +nc'-^a/J(a)jl07NeV.FL`rVtgTEr^jlF!^j-s8R0<EUV\pA(g#$f$;LhguRgt`65"CkMOn;fAGcW +?ISHBp&><sr;6?dqYU6jq>V90o[oo(kMOn;fAGcWU"4/ZrVc_:F8g7Zs%<.Ra._k\gsjQuh<"$i +@;P]2C0e=5iS)`&P&IF@T$,U;j6OjiG4b_0DTeR;jk\J3eD0-OU<)Zrq<Q%nm,ZsOeD0-OL;n*, +F8l1CF8p<&s8Vt;!rm=_r;QcDo)F4~> +nc'-^a10:/]Y),+XLuKmrVuKgaoKffasI)1s8U7>aR@orYf<u=T!uJ0Q`\35`65"$[@`trSY!75 +X4-V:p&><sr;6?dqYU6jq>V90o[on^[@`trSY!75U"76\rVc`<b5TQ^s%<.Ra0ERbQ_V9gR]siL +\AS(6_6h:rVO+@*_S*q&_nr:9X2</a_t<m(`QP7$YaV8sUR/+$Z,l8,q<Q&)`3#B$UR/+$]Z.nd +b5VDEb5]W,s8Vu=!rpEcr;Qcao)F4~> +nc'9SXPhXI]=Z#7iG<diqYoQ0L&[A9KdHbQrqqE>IaturhU/3UF(T]X[b^G5bKQ^LeZ=UMM6#1q +E7a^[q>V!)rVQEao'PZ(l0e6@rVuorrb)3,n^X9#eZ=UMM6#1qS'QTTo^qg.K(aiorVlfkjh&%` +^ls4eKqQ]XKm&"Cq0mFMlH,NJDd5q0:1/-uVU=h8^P_gcr.3Fnn("LrFafLgjL;_]p\F-qVs;Bn +K7]Q5lBK;<qM"qK"blu1L&_2MK`_:.L&CrNf(/ik~> +nc'9SWnHRqiSih\fii$+qYoDoF8pmlF!^j-rqpd,Ct6(]g#h/BcG\,`iTTQ_bKQ^HkMOn;fAGcW +@+Y#Kq>V!)rVQEao'PZ(l0e6@rVuorrb)3,n^X8tkMOn;fAGcWS'PsBo^qfqE;";KrVlfkjh%_] +inDl+e_T?SG%>Leq/'Sqm,ZsObbf&mFg96ChWF1&^O#\Sr,:/\lf[0WcdLP,lE@e[p\F-qT^:ap +eC<:7m"WMsqK)Z9"`s]bF8u:;EruA_F8Z%<d.73e~> +nc'9SZH9MTVP^E'bd+t%qYp*/b5]ifasI)1rqsk._pu;gaKh>-\&ke@UUnmMbKQ^)[@`trSY!75 +Xk31Cq>V!)rVQEao'PZ(l0e6@rVuorrb)3,n^X8U[@`trSY!75S'T%Do^qgsa7dUOrVlfkjh&4@ +W0XBoTpi4+\@]`Vq8BhV`3#B$^;[e"^;d[TS?g8I^W6-Kr5R<^bdF(5[&B:h^V%/=p\F-qZ,Ec2 +USF0X`4X+.qTAg;"j6kfb5_M=ao_Ucb5D8>mIL:-~> +nc*OK[-uPGOH>aGkFupAn+bmrL&R9iKnT>Up@*O`FJtS`dAD\?@;LIZ`95R;eBafVeZ=UMM6#1q +ES:!_s8W)trVZNep@@V6hpffb^;J=Un+chXq=jUUo^V+fQg`J+M04ZUeaJ@(GLtL"fm7s@hL4ea +qu$0FYL217Nd?)7]&<*nH%GnjJ9ZA-dAD\?@8BKj?uq+#dI*XPNVi_RK&3]Ii4G(uH&f>hd&Ypm +q!?,$lH,NJJssdGPf/(JL&V)UL&Zj\s8VtM!rmt.r;QcJo)F4~> +nc'9DXR#',g=k<Al]tjkn+ba\F8ggkF&i*Wp@)nN@]5OEk2+\7ZcghPj6OdNeBafRkMOn;fAGcW +@bLDPs8W)trVZNep@@V6hpffb^;J=Un+chXq=jUUo^V+fQg<hlf?`(+kNdu6A_5Se;qYhuhJ;NO +qu$0FYKH+gg!S7%iT]W0B5d_FDe<\Lk2+\7ZZeTUZ-LqWk3SV`IJa$BESdn-l/C@EdFmLBafF1f +q!?+sm,ZsOeD0-OKu@j)F8l1CF8p<&s8Vt;!rm=_r;QcDo)F4~> +nc'9D^Wa*WQ^<u<_SNXqn+cFqb5Tceb#S>[p@,uP\Yu4BZCIMq`knU<X2<8heBaf3[@`trSY!75 +YM&RHs8W)trVZNep@@V6hpffb^;J=Un+chXq=jUUo^V+fQcuk0S@"iY[EOK:][tfg;q\q$hSS[Q +qu$0FYK=ANRBETXVS(E^^;g*J`kAb%ZCIMq`kJmq`jhY2ZH8leb5;2:aPO,A]V_$rY*l&raK+(e +q!?,-`3#B$UR/+$]>VYab5VDEb5]W,s8Vu=!rpEcr;Qcao)F4~> +nc'9;b4!l]M0t)UdGB"cfBCk=p@j[JJoL1-hpQSFL!f;8VMB5$?uLXcaQfS"h9hk`eZ=UMOLjB? +F4p-[qYBp[oC)#,hUTfaYbA&-`lG$ifB`%tki(=Mf[S$HJa_-jM04ZUeaI.-BVD/pUMFYIER*V8 +q"!(5n("LrFaT:^i4s2VK)PX-JpVC^h6r>iB2q?'Ck.ehkL-KfO8]+XKB9bOjM6t.F,-X?m\%qq +p[6;,lH,NJJssdGP.uJ@K`:rSL&Qd[rr)_I"T*k*rVlfr!7p`@J,~> +nc*F?_!C1@f@&7,k1O9PfBC_'p@j)WE,b8_hpPr4Fis+6hU]uYZ-:_QjQr5-h9hk\kMOn;g>V;] +A(gGKqYBp[oC)#,hUTfaYb@es]t^>SfB`%tki(=Mf[S$HJa;LVf?`(+kNcc;<hZ7^;kmK!X^KH7 +o(_e.V!I4$f?_n!iT[dUBlO%LE+rRtl/C=C`JdH]bL>5+lc?3`J,TEHETOj1lJgOHcIUk7m%)Ml +p[6;%m,ZsOeD0-OKthI!F8l.BF8g6%rr)e:s)J8>EcV-Xrr2uFo)F4~> +nc*F?cciegSZABQZH'5YfBDD<p@lhQa2dYehpT$6\&l[rS=[40`kS:8Xi/)kh9hk=[@`trR&7OG +YhAUCqYBp[oC)#,hUTfaYbAD=`Q,6qfB`%tki(=Mf[S$HJ]tNoS@"iY[EN9?Y+_Sa;kpS%XgcU9 +o(_e.Us-6=S@#>aVS'sU^rQEPa2#%)\tb[rahbO*_PWU!_U,F?bl.S@aQ:(S^SmHs\=]:sae[;P +p[6;5`3#B$UR/+$]>)8Yb5VADb5TQ+rr)f<s2bE@aiXM\rr2uco)F4~> +nc*47am[c\M03lpVU=7AX2DYthr*F?He$BWZ(@3,mG6$aLN?m+F+Tk%lJl]gjO'LdeZ=UTOLjAd +Ems7=lK@0_f?_FIY+_Mj_scmOi8F"D[FF'`_m?><U7RUANp=`UK5YmhX4?t5=OF+bi:--\TC1+( +LNA'9aQgZ_I=qOuK77j9kJWX9D-KS>F,-X?m\IV[OT,:[K^6^ElH,NJDh=G!lD2;\p@-Ohn("Lr +IZhJ,YdAcGK(o!4K(X_Io^r*6$A!`qJ:[ChrVliJo)F4~> +nc*47_!C1@f?_anhWEL#X2DM_hr*F-C":JEZ(?]lmHN`hf$:UhcICY1m+PXHjO'L`kMOn>g>V;, +@ajQ-lK@0_f?_FIY+_>^]BehKl07TM[FF'`_m?><U7RU;M!X3XeBH7jhrjb"=NRAUi:--\SF#Cp +f$;e#jQsB`CN9@QEGT'Llf6aKbb&=KcIUk7m$>EKJc>]LEpLf%m,ZsObgbG/m%2)Xp@-Oblf[0W +db<^GV6jt*E;0)"E:n0ho^r*$s)/22DK#4DrVliDo)F4~> +nc*47cciegS[>kuS?g5>X2E2thr*G/^t$]GZ(AVMa1ALFT!u_W\>,Cm`7D3;jO'LA[@`tiR&7O3 +YLD_%lK@0_f?_FIY+_f&_p$'6]Y);*[FF'`_m?><U7RUKQc-"mUV=++T!e:9=0]X#nEnSub-IP/ +\"f:l`6Ga-aSu1[_mmP"X-KNu`4X+"T:E4/_nY?Zrr<#?lc?cXXd>fsUR/+$Xhs;qnC+,U[@`tf +QDhR:[(u.Np\+=$ouG,Fo_li1`X)"O`qB0+rr;BVs*t~> +nc)Y-^$jLPM039KLSiJe[@<=qYHkHOCnR8m`:*!Ic*j=$F(&HcF+Tk%lBlY.kg#aedAD\HOLjAb +CqIj4`P/a]U7J-idI6Jci75rb]=Z>NZ*V*B]]&eWs69m3RtGWa@WdO/pXLeMmB4Okk/aLdad[p$ +JssdGPB25+rr7Y%GB`K&VMB5$:LJ7!VU=gVcgHtqs!`WjdV81#XGM(IOLjAf[,CTIfTP^RXGM=d +]&:>mFOtothV<G1H@"5rrd"rtG^%>TGi%`Xqu51;s*t~> +nc)Y-[-Qo4f?^qOf&#QUXI"rNYHkH=>+h:S]BehJjl,%HcEjdccICY1m#,>akg#[ak2+\;g>V;* +>eA/$`P/a]U77dYb3SH\l0%-eiSinaWjB@;[+YBCs6L$PgsjQF\BidapZF'kmAS+ek/a:`jP88/ +eD0-OKjnn=rr7"VAS1;khU]uYGHoHEhWF0;cgHDas!`!XdT>bthq-3&g>V;.[,CTIfSo.Zhq-<1 +iT[b>@b5APhV;huBP?&Nrb)[PAnB.sBAVqGqu4t5s*t~> +nc)V,`lti^S[?GHT:E40\tl%*YHkI?ZCmnn_p$'1YbRYY\&QG.\>,Cm`4NS3kg#pFZCIMeR&7O2 +WOp<q`P/a]U8"j)aiqfB]X=l?VP^T7\[/rJ_>DIV`!EK3UV=^f[%3f_[4Ai/\&dXmaK`[cQ_V9i +Q`\3<\\uSgs2i6mZc]SDT!u_R`jhY2ZH9H!ma(n4.EV)-Y0=;GS@#>aVS'gRi:QTmWQ_cBS?&$S +]Z-GOf>6A$gq_UX^Y%3<^C.ch]Z[t%hWjb1rpB:VJ,~> +nc'0HRIA\,M0398F,-X?jR)E^rkh(<i:$+!i75rXToOhJA861.LP`(^`-6OKlH?0lad[p1OLjA^ +?]1/JV6.\_n*]K%h:9cg]<%KcOH?p,d?'OMjOsI]s2bP9K5Y!k<+:!,pT,mRg#90eh7o`Mad[p$ +JssdGQ$.\2s8Rb(H>MNmZ&Ep=<,[AWaQh5lh=Qm0s!`WngMGg$Z&EpMM6#1qUt5&,hO2^G[Z5Zl +Z.\#UAuBONY,Q33CMTZ=rb;gTBU>]aLpG1^o)&FWs*t~> +nc)8.O6budf?^q3cIUk7lL!oX]">S_f^%njl0%-dh:^?(^<=gJf%8gB]k;&rlH>shjP885g>V;& +:Q(I3T;B3Blg4!'l0%0giSWGig'?U#acM\=lKJ0/s5XI@eBFe;MR_!apYRL[kh32lh7oNIjP88/ +eD0-OLLb:Cs8R.ZBj03Ri7QDkMTjT*jQsunh=Q@!s!`$]gKN:oi7QE&fAGcWUt5&,hNQ%FiRuW2 +i98d6<2X!*Y,PR!=]qJnrE'D-LnfcOZHD.squ60dJ,~> +nc)Y9[*5qLS[?GW\"B1r^W4R@_Sa:4bfn5J]X=l:R[KkYaMt`sT:MR]^pLo8lH?NPXd>f`R&7O. +S;WW<YI29hbf[l=]!\cCVOs3@Q^=JYaH2S/^UO-Ks/cQnUV=^^_8ipRpR`t2\'2).h7p)1Xd>fs +UR/+$]t;8*s8U6^^p;1nTpr=._7ub3Xi/Yoh=T(ns#A0ngTo&4Tpr<oSY!75Ut5&,hQY27URA9S +Tsr3dXJ`D/Y,SY#YcsjrYct=7XhV3W]<]T<o)&FWs*t~> +nc'0VN6pChNd>MP?uq+#^s1EcrSSpRe^;LNXIG6(H?!kGIYWcWX4>"cJq))3aJeCGRtGX,OLsHM +n,MYikMY1HdE024XJ(o@M1^8)MlYCsFL1&DZ2C^'RfS.[raGtABP;P_M(>%9lEJOb\AdC<OF22- +X4?ZQG_(PJs+Q)REO4`APC@:PDh=G!lBHDSq31gX,),dNE5LPFOF2&%TZuktbO"i\Tu,a"OF282 +Z.\U7d)!W:p$_nF#4:BQ_rC@fo)F4~> +nc'-UK#m38g!S!WZHh%XioTA$kp,ETk2bLYgtC6*c-4M^f%8d9kI7I4D92%aU?psreBH@piT^@- +s6LTgl07BnjPo.Uh:pZ8eC2juhrj<IX6S^&r87P0!S#?m\-'[kaj9_5/)94PWm0/*^$4M0da-P& +kNc2]DfYmXF)bu&WTrKse'"T3eD0-OL19BBKDtlpF8+[#\EVu+d`p=ujmAV^m.98,\*;l*da6Y) +kj.QV[^s'Cli-5TmFnMViq<9@s*t~> +nc'0VZcp"URBFEJ`j_P0W3E\@rOaAa[Bcp3T9kt>Y.DBTW1TWNT!cJ9^r5@#aK`[cQ_V9qR&7Oq +bl>Tu_S!IfZE:(#T:2%3S>3$`S"@%3FLf/bU&:P_QN<kqrl5,_b0%*cS1Br.`4=.E\Ac+XQ`IKa +T!ceF]uJ1os2rF"[_okYQDhd@^S@-t`4WYEq9]-@,0KZ>[E#qWQ`I`lR]si4bO"i\\B2C\Q`IB\ +Tsr7iaN268p!!ER#04rt_rC@fo)F4~> +nc'0cRtpCUVMftKDeO3IPG,(drOX;ZXJVJKM1^+oFaSdtP,>;-e\H%JMh9@BaJeCGRtGWmI#tu> +ec3`.`4NIZVONd0M1pJ-Fa&4bMne?DB^aKQN;SP4K)foiFT?^[Hn9lHdI+0[e?m0P]9%DfOLjB? +CjL\ds8RfLJ9?_9c(Ti2A:Tr`kMg9&nbeUMruZskl#`9Wad[p$J<e(9Xha,ll)U*7ad[p$GDrfW +e_U5_p!s&`#0kigWQso-o)F4~> +nc'-bOa-9ThUp<(bfS/]g>1Zai?R:<hV?i:eBuOedaZn&hV[JY\6I:+EQd[hU?psreBH(`g>W%o +s5Y$WiSi\NgtLH5e^Msmd*gFrip,fBlf[0Xr7Ctu!6tJg!7CJf/C`P=m&8(V[(PY^g="F'iT]W2 +BlJ.ns)\$SA:3e+h:9cae(`pKfii%Yr.G"K*cq2B@Z'O5gsjQsgZ.Us^ut@SV2"?tgsjQpf\krU +rTX"<ro=:Fkj>1kmJ?DRJ,~> +nc'0c_RddlS=?C\^WO$WQC=G@rMCg5T:D77S>36u[&]smQCOPP[D]AsaN3T2aK`[cQ_V:;X-]^_ +[K!?GX/;YaS<oP0S=ud[['?[,S#F*RB[!lVS,AfVUB%q)ZiI9%X":$9ZH9W!e?m0,VO+?aR&7OG +Z,"E&s8U7<`OiS!YaV8saJP6'_UPj)nbgc5ru]D[l++@CXd>fsVNn4![_V(ul,(-PXd>fsZ(%Gp +[CZ@MosOe$#-bSWZ-Mb5o)F4~> +nc'0mWH+9hdBSspJp_c`IYEW=rK&7_M2-_2FaSXiM3+1,^X:TgUi1MBOG)'LbGsjLRtGW]Bmc$A +XT+b,Q&q#_LP(&%Fa8@dLP_+]X2!`#EpqP[M>_f(J:`B,rJ:N7oT1T#dI*ONf!WHS]9%DhP/$(r +Dg[1ks8RfNJU2A*eZ=UMFb#q%lD8QNp\pBUruZslmWXTVc(Ti2I#tqt_m\Rsn$RH/dAD\?A9a'7 +XLA,?orS.^#GJT^e%=]9rq$/?~> +nc'0mT4!H@k2>"HeC)^he(*('rRrLKf@JI"cdL7kf@o$;io]FXT3Z'nJ9&m$bG=LcgsjQ8b0o#C +huDIKgY1?4f$r0rcdC1jf%8X2hr<ptEpMoGfDX,"e'umtrRV&&o\(hPk3SD[f!W0TiS)`.g>_D0 +?>FP%s8R0<DeNVGkMOn;cdU\1m$V9up\ogEruQ7YmU^h6jk\J3db<[E]XHhln#pHlk2+\7^<kNi +hu2O,hu;C9h;RS@]B&bdoDa=~> +nc'0mcaUU+ZD!PQUT:Z/W1f`LrKeauS=ZLV[&^.#SX>b8W3WhNX0fS)c,o5;bHo-hQ_V:4b,^m. +TDt5pQ'[o/Sti6e['$I)T:M@9SuBEEEm1q`SGfJjVPBo[rLEqVoU%/!ZH9;rf!WH/VO+?^QDhR: +[DL#-s8U7>`kS_$[@`tr[&01l`4rh"p\rP=ru]D\m_$$LYaV8sX-fcs_m\Rsn'&2^ZCIMqaK_5, +T;2C_oq25M#F_F!b.Ha0rq$/?~> +nc'*rZ?pShmb,O`RZNG_Jq3]F,(P8sLP_+UR]F$@e`?/&Uq_5+pQC6[nC"9&c(Ti0C1q:.re^Z- +(k@![H$k-oLP_%QR\m-saOTA/FcG>4Z','I"-o=DT`(nk[e.-]aOSk7gYKK]i4G(uI\tN\]5rFR +L&_1,re#WFZK/fbM2@86lJlo1Jc#J2rr4'orUY>Wi7YAoG_1dQeaKa"o^on;_Vi%fIWojXM2@8l +OS+J0K*R76eaKa"pAX[`J,~> +nc'*rW+fV4m-*KfgtLE3eC49B,1G&kf%8X0gu%)OkN_E1U;(AZpOdP4nC"*!jk\J2bK7lSrn%2" +(Xpg[dF-Lnf%8U/gtprIjQGg]A<#:+i;D:2gYCT?rSR5*/*,m<RbQZ1^$4M0daI"7m'L5=EHD0[ +F8g/pC8^@Vg=Os0jQtT0B5d\IKDtlmF8b]EAD-2)f[/."hrj=0ht6QO?ao:Yg="?nd+?n&rn@%s +rmV2)hrj=0htI'@s*t~> +nc'*rftb&#ag\=EQ^F87USdmg,,V-1T:M@8Q_((V[D0huWP?3epX%(KnC"P]YaV9#`lcH)rga"` +(o=:9Y,eFpT:MC;Q^jYEXgPpcZ&Qu:TpGYE"-o4>Rf/fXU\(E6XgQ]ggYKK\]V_$rW1:08`4<h- +b5_LarlDsc`kSI<SXl1N`7D-+`r#e_rr4(_rU[h0bdX:8Z(mk][EPl4o^p_Cah4L;W3Nk;S=H#H +Qh?mJUBd?][EPl4pAX[`J,~> +nc'*u\:Aq>T&AebaL\XRR[*`2+-i:`VQ7;CaOT56hQihocf9S/rKDrco\?(sfs-KfIf+R4J:`B, +M2@7SQ("SN[^sQ-e_o`LZZC,kVru=>rON*LaN2X)eH"Fti%+*MXL%-P`i\FBQ&q*)dI*cSmt?Dp +s+UK+J:`(7dC-*V[`Ia4I=?hJs-*H^+GKgiIXAK`^lsA%TXs(OZJbHOaEMptdAE(bLOsu&I!>7+ +!."Qk#_8APh=.W*pAX[`J,~> +nc'*uY&A$fS([,kjPf%RgtV\Z*o#K*hV[;OjQGdofqt?Jcf8q`rI]1;o\>qhkht+CqpHG4eC<%# +f@em4gtprIiT0.al0R*$@pcL1lfI.)i</-$jQ6@'!9j(>/*tuiXm"ldU[-spg=kEGm%J%[Ec_9\ +F8p8uEbXn&iSWPOjQrUXCiTISKDtljF8krNCT?[Zg=4X.iT]X5i:cr_ASLMnhV-W5eGdkrd.P]b +dJhQ"e(ipGlEB+=rq$/?~> +nc'*uho<IFU<UQaXeqe^Q^.E7+-i1ZS=ZUVXgPg[ai('bcf<$drQr^Ro\?Un\"T:dW;N\8VPBo[ +SXl19Q'\#4USb0![CjH"`NZeU^r!=SrMB[tXf\i+[/df1]IUqCZ-):l`kK<jQ'dr/ZH9)Zn&``P +s2tA``P8k(ZD4"_UTMJ>]#2Vgs3UcF+Nj]Y_mm\#W0X3RR\maIZJbHOhn6A>ZCI5MT;/?cX0M?) +!3Z=%#c<r`]$de>pAX[`J,~> +nG`s0KRr(&CnoqRi7ZN!`;7%e`5p$Ie_oNRn&(E2ER0%"p4S/"PD.Q^kH_PW^oNoer/_k_R[TnM +X1#UXaO/Poi9Kaf`2@ZsK6u$j_sQO`hui0-lL"Q=!7:PW0Z1`C`58R!cc#GDeW'"E`4EP$e]#+I +p4S/"s+UK+Jr+Q8mG6=Ch<MtfL4P$Xs-*B\*rCJ?JDS\YR[Tn\m`*$(q#&EcF-Z%<^TjZ)P)tc` +on`[/rf@DNR^VM2]&`YcoDa=~> +nG`s&Ec9mW>*dk.l0.9jj8.^Uj5f:`kNV9ulb&!^@*`TTp2Y6SK6,B6kH:lNinrPgg)Jf%gtglF +iSihXk3(smm-NE<TjqMPC!p\*mHXZ7"7,=?mJZ>PaL8PS[kPG'\%K5IB@"<`n(!$Vk2YFZjQF7g +C\Dgjs8R0?F)cJ7M!aEhkNM9I[WZS0s8R`Lru1cQF)p!si8!,DiU".jk4nkrCLN%ck2P=Uh#?"- +f_*hrg&B\2gYCcSah$R.rq$/?~> +nG`sVai<8[ZGFc']XP2KX88\8X0&M0[Cj8mbeq,t\'MnXp;tJWd)tbNkJ>0QW1K?Ar0SFgQ^=/4 +Sti0`Xg5(a)G]Yqq6`3HPV^qeC+b/_9q]E?$h`5hi#!m&F&qoCJ.aN2<A[C"97oC(5:b-J(FVQI8B +]#+0`b5_Las2rF&\\?+q[C*Ta_7%8$aoDCfr;Ri8`k]"&ZD!VOR\n3S^ZP=hk/+XB`3Q>8S<oP/ +R%*c>!1EhR#aLaO`7)<Yq#9mbJ,~> +nG`s0KnT*^H#n&*_;ObHkPF*YkN_@#n%cGuC:&,:II;^`rIot*PD0&7n\fXgjOM>dr44>qaN2WV +e_T0HlL+,e_53cF\As8ONIgDKEJV6G_84'kPc0=NC29cLDYe9*[;^)AF0C>achd@tO-f:ti8EnI +Y18(!Kn]R,L&Zj[NdPo(dI6POQFPP*K8'@*PPkG%rI]rTRd/SIaN`Q/HID9ZrmQFFEL#tQg!RmU +]"50>WrTU-\d-0pe`rLFm/$;QJ,~> +nG`s&F)pp:B45;E\(L'6lh]iGli-5ilaF$Q=L;R[C[Q0<rH!&[K6.(jn\AeIlK@6fr8B-cjQ,Fc +kNM0rm-O&Y\"B1#\Ar`.I;eFo@!T)l\$s#HKqW]l=BVT(>[@550XY4nI:9*ulcK"sk(JTXlfm[# +afa04qK$`Xs)\3]Edhb3Gf]4:aG@@XI;s?.s+C7L*rU))D2moGjQ,FdltXu;qu4iYBjZ\_lKIBk +io/kSp##`,#NOn.m"rsQqXXZ:~> +nG`sWb/s;>^::DQaNVcE_YUne_SjC7bf@E1YdD!X_X>J@rQ<:_d)uCdn^Fke^U:2Br2(sEXf\h8 +[CX#f`6$6HaKD;B\AuJ(b/Wba\%BGoaN2<-]<SoLYHXt,[']V9+Lel$_s?I]p?''(ahk^'`5o+3 +`qmj#s8U7Ab/qiC\@VX_#emh#b/ha*s3U]D*rX1#]"GtjXf\h=ag]^equ5m#^p^u!^ULMNW2?Gc +opu/Yrh]q$XgQ*^bj>2ss*t~> +nGa!1Kn]L#JUW9nEGTluXi^IV+/5QrTVZS?Fa;npNe@4^s8Re,s-*K_rqY&rDmSotjS[pakN_@" +n*eT=U6Kk;DK3VAL#_KZK9Co_NI5ug]5V`#^N@SAG^=\jh>)FPidH6JI`RTGec,I;SooCU`knis +e*;SaKn]R,L&Zj\Ob%q)EGi"#G2;SJKSBI+PPbA#qi6GYXPrI0mEp6&k4eiSeV&L#F*Y(Lmcrlk +i7[eR!8[Y4#NtC@V/kMdrUTu=~> +nGa!'F*%<TDesR;?Wq*9VSrA@+-iFQSY]W*A7sh;IW>7+s8R.]s+C@OrqXo^?)[)UlMTlqlg4!* +lg)U#Q%ipS>[PFrG2qn;EIr6+I;3B3]3epV^LG;rB4tu5h.le%0]Hk`P\e3dq9T';o9*TuR(g). +?IS1ZrH!&[s)\3]F+J7FARJcI?Y&!\JTGo4s+C4K*W(;0CSoeOm-Vl.AENXbs3G_(Bjk_Rg$J(j +l07F)k5a`Fkm-P@l^2,=o_n@\J,~> +nGa!Xb0'\X`l#[7[^*9F[_DX[+2G%mV5:Q4]>!4AbK0S's8U6as3UfGrqYTi[)U>.^\k_n_SjC5 +bfn8O^qI(YZaRg!_rL(+aNr!'b/(d/]=,/Z^U_J!^;%G;h8/s)0]KsdcGSSaq<\+Xo?=eT_o9a+ +[F=E^rQ<:_s2tAab0J#D]XP8P[_(A`cH=<0s3UZC*W+$u\@0W"`5g*1]B8kds6[qJ^pphlbfRf< +]Y(`H[/df;]Ec<lbepsKo_n@\J,~> +nGa!1Kn]R+KS,<NI<p.[_5dEP'le<6G1,&kk(&$VKT_&hL&_1,L&[A9s#'c2N-]QCWj9IZ_nj9c +Pa-upCMn*4Fa/4[IHp9^p\L&,PD0!uJq3+II=:5?J*hc;JqE[hq1C6nK7g1Vdus^]s8MnoIX-(P +FO#7#pOrR#L&_1,s+Q/jKS"`'I,B@&o_Oc*rr2t^qu7]9OcG4<G*nVtE-Hd'r;ZfJKnP#*G]InN +Pd8-Bi:ZOHcbRB9UR%s&I.7"3o)F4~> +nGa$(F*%B\EcHQoCM@D&_5:T=?N4@H@Dud*fkTYeDt\4'F8p=]s)W8]KDtm.rRuX4@Afp!\%KA_ +]Tn2+GFhuC?=@>UBPM>Jmsk*.JocQcrdf$,l/c\rjl^LJDf9T6p%J3$/GO4)SoN#-rm:]Eqj_J8 +A&2X"C$kY9s)W8]s)\3]F+\LPDJX(FCMre(a)K6.%l!/(1K*WCV=GK=BRM5O]lD"RZ*s3Ph-Deirn +AS?gq\%:5blO1bA\%S)`X(,o6qYp'cJ,~> +nGa$Yb0'b`aiMZk_SEk,_7(a)#R[K!ZL\Ac).ftlgi`qIO#b5]Was2rLad/O&&rU%_A\>Q[PaMYp: +`5'!u\Xp(4[CEf]^VRePn'(P&ccXVWrm&R(l/fe!jlaSL`l?'>p%J4&/GR<-fZ<@)rpBabqpr[! +]"tr&_!Um=s2rLas2tAab0\8N`P]OL_Su0Dd)u@f!7:WC*<+7,`5o:#^U1G^_t<m,s6[tN`koF! +ZF%<aaMRSn$d6T3`500g]#!n4rpp)>~> +nGa!1Kn]R,KnY]dK7\[@kg'*Ss*bXHJFW8`q1OG#Kp.5jL&_1,L&[A8s"<;nJUZ7pF)eXrE4U+4 +Fa)>]I!pHoJV&K+qYZNUs-&/#L&[?iK_kIrKD>7qqu26ML&V)IKc'iDKs$-\PQ056s8K*PJUcm5 +mXk<6L&Zl+rt'naKnY_EKS4u1pOe.trf`'8rrA8ZruI;cO6MFEGh%1lK)GWJs42mXKS+f(L3Ri] +E3X7rrbE.@C20K<CMRa'DfE:/bh7GsqYp$bJ,~> +nGa!'F*%B]F)us0EH#j_kfWg=s(iA6DXm@=q/UQUF+\Q6F8u8]F8pmks"E8\Df"(L@:-IN?b0ZT +A7a8(C27X'DfB]9qYZ!Fs+>BFF8pl6Er,QNEVT?Mqf;[Ws8Mh8)#nYuU3"\6s3UfGrh+7LD<Pj) +E;KNSs)\2>&9IkmF+\OTEcH*nEH;$WK6.%l!/(.J*J8oml$$cPeS8uAr;Q`rcuX8KEGoZ:An,7V +Z!1E2=V@H2=JDQn=^#$8?FjUifkbX(rpg#=~> +nGa!Xb0'bab0&',aN)<ekhZ0Rs2,N8`UWTAq8peYb0\<2b5_Lab5]ies"Erg`l$HP\@/iR[^ruZ +]=cY._8=+/`lH0AqY\_>s3Sp8b5]i2ankeRaS>SQqoSi[s8Mi:)#qb$grf$2s6]jdrn>H5`9>/- +a85bWs2t?@&Bb$qb0\;RaiMQtaN=D[d)u@f!7:TB*RN*Ul,:<Le\T5Gr;Q`rmE3SnaMu-8]t1_^ +Z*LY6YS*\7YbInsYd(L@[CWomfu(l,rpg#=~> +nGa!1Kn]R,KnY`jKnP-Vq=so@(ANN7qLneFL&_1,s+QYjs+ULQKn]PjrVmSmPD"S[m='KDidKp; +It3+@JqAW-re1<*s8N^qs8S::PD0%#Kn]R,Kn]R,L&_+*s8VnK#lfU4Y(bGjs472L%'G;;K_^;u +K`;"*s+UIP"GQl0Kp2Fg#6'=1s8S::rr2t^qZ$SZ#a5"EJV!BDKS9=(!7q+&$&!qlJUi2ti8&bZ +HN2V.HJ$nsH@(!dIH>tHo7M_qnGe"~> +nGa!'F*%B]F*!!6F)uC!q=so.(AMlhqJuN4F8u8]s)Wg6s)\5?F*%A6rVmJfK5tu'm;6Y!ibRXl +D/O:_E;jkWErL.[rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^As)W7UF3oR>d/O%RU2t?qq/Z@R +rr7'>F8l1BF8p<&KD]cprc</\s+>Clrr@]Js8R]WK)'q8Dt7mgF8c+=d/A"lEcHVJDJX+Hh.ck% +s4@Eef\'s;BaAHhj_aGWEH;'Js*t~> +nGa!Xb0'bab0&*2b0%j'q=sp0(APtlqT8[6b5_Las2r^2s2tBAb0'b2rVmK$d)jB#mDQm%ikjfp +`5Taea8X0[ao9H_rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ogrda\q8rNV +rr:.@b5VDDb5]W,d/;#jrlWC`s3SpfrrCFBs8UFOchYi*`q%3mb5M>?mJY06aiM`H`P]RNh8'$) +s4(a)Fgf\+%=^^.cnji$TYaN=GNs*t~> +nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]%-3V+L&Ln$KD>4opk/R! +!<)\Hs8N^qs8S::PD0%#Kn]R,Kn]R,L&_+*s8VnK#lfU4Y(bGjs472L!3Z<T#lfVYL&_1,s+UIP +"GQl0Kp2Fg"oj:1s8S;]rrA8Zs8J2brfVqfrVhNLrrCXIKa*]nKS+pOpAKUCoE'X;p&0LBK*D%' +qu)5&n,In~> +nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M%,cbZF8buUEVT<Kpi6:R +!<)\6s8N^as8R^mK6.'FF*%B]F*%B]F8u2[s8Vn9#leseU3"\6s3UcF!2BI6#leuGF8u8]s)\2> +"EXTaF+aC3"oiXbs8R`Mrr@]Js8IWRre#63rVgm:rrCFCEs@8;EcH*npAJt1oE'")p&8q0E<Z,X +qu(SWn,In~> +nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E%.higb5M4YaS>POprNHV +!<)]8s8N_Ys8UHgd)uC8b0'bab0'bab5_F_s8Vo;#li&igrf$2s6]gc!8RRr#li'Ib5_Las2t?@ +"Npbeb0^(/"ol`fs8UIErrCFBs8L@Jrm8d/rVjt<rrDH`ap-57aiMQtpAN&3oE*)+p&<#2a9D@\ +qu+[[n,In~> +nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO +s7h<Jrt:Oqs-&/#L&[?jL&_1,L&_1,s8@ZOs7q?Ss+Q00L";Iff)G[LY5X+\s+UK,s8RfQL&V)T +L&Zj\s87QSs+Q1,s-*E]!0d9Zrf[KbPD+_jre:=N!7q%$!0dA8s8MtNs8<"Prr2eK"oj;Vs+Q0q +s*t~> +nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M$fHYYF8u8]F8u8]s8@!= +s7g[8rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^As)W7UF3oR>d/O%FUAf3>s)\3]s8R0?F8l1B +F8p<&s86pAs)W8]s+C:M!/(.Jrdt@RK6),6rcA&<!7:Ua!/(5ks8Mt<s8<"?rr2e9"oiZDs)W8M +s*t~> +nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(? +s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ch#>G%s2tAas8U7Ab5VDD +b5]W,s8:"Cs2rLas3U`E!7:TBrm1fJd)sN2rlY3>!:B[+!7:\es8Mu>s8<#Arr2f;"olaFs2rLQ +s*t~> +nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO +s7h<Jrt:Oqs-&/#L&[?jL&_1,L&_1,s8@ZOs7q?Ss+Q00L";Iff)G[LY5X+Zs+UK,s8RfNrre&U +Kn]R)Ka%L1L&_1:rVlk]qZ$PY"TO[>L&_.+rVllKqh5$6rIt:OrIt:O!ep[Sqh54RL&_1,L%#%l~> +nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M$fHYYF8u8]F8u8]s8@!= +s7g[8rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^As)W7UF3oR>d/O%FUAf3<s)\3]s8R0<rrdEC +F*%BZEs;SbF8u8mrVlkMqZ$PI"TO*qF8u5\rVllEqf;airH&#=rH&#=!d"DAqf;r@F8u8]F79-Z~> +nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(? +s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ch#>G#s2tAas8U7>rrgLE +b0'b^ap%gfb5_LgrVllEqZ$QA"TQikb5_I`rVllbqoSocrQ>0?rQ>0?!m:QCqoT*Bb5_Lab4#@\~> +nG`O$L&V,PK`RD;re:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO +s7h<Jrt:Oqs-&/#L&[?jL&_1,L&_1,s8@ZOs7q?Qs+Q00L";IcrrB5$Ka.R2s+ULQL&CrRL&Zj\ +s87QSs+Q1,s-*E]!0d9Zrf[KbPD+_jre:=N!7q%$!0dD9rr;qNs8N.Ss8W(P#lfU4s+ULQKn]!q +J,~> +nG`NoF8l4>ErgpnrcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M$fHYYF8u8]F8u8]s8@!= +s7g[8rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^?s)W7UF3oR;rrAemEsDYcs)\5?F8Z%@F8p<& +s86pAs)W8]s+C:M!/(.Jrdt@RK6),6rcA&<!7:Ua!/(8lrr;q<s8N.As8W(>#leses)\5?F*$gM +J,~> +nG`OKb5VG@aoTlhrlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(? +s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seAs2rL>b3dRRrrCjRap.mgs2tBAb5D8Bb5]W, +s8:"Cs2rLas3U`E!7:TBrm1fJd)sN2rlY3>!:B[+!7:_frr;r>s8N/Cs8W)@#li&is2tBAb0'2Q +J,~> +nG`O$L&V,PK`RD;re:@OrIka]Kn]P\s8RfQs+UK,PD/u8s+LLRPPtLhjHG:Os8Re,s8RfQrIk7O +pkAbJ&sN@qPD,3Ss-&.js8Re,s8RfQrIt:Oq1T%QKnZ[`es$%3!3Z<T#60DWL&_1,r;QqSs+Q1, +s8@WTs+Q1,s-*E]!0d9Zrf[KbPD+_jre:=N!7q%$!0dD9rr;qNs8N.Ss8W(P#lfU4s+ULQKn]!q +J,~> +nG`NoF8l4>ErgpnrcA)=rGrJKF*%A&s8R0?s)\3]K6."ks)S5(a)KDkfXi.H)ls8R.]s8R0?rGqu= +piHK8&qg5aK6)Zds+>B6s8R.]s8R0?rH&#=q/Zc?F*"'sd"D8r!2BI6#6/cEF8u8]r;QqAs)W8] +s8@!Bs)W8]s+C:M!/(.Jrdt@RK6),6rcA&<!7:Ua!/(8lrr;q<s8N.As8W(>#leses)\5?F*$gM +J,~> +nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/EtPo?bY&s8U6as8U7ArQ5-? +pr`X:'%$[Yd)s_Xs3Sp2s8U6as8U7ArQ>0?q8rpAb0&M^mEke2!8RRr#62jGb5_Lar;QrCs2rLa +s8C(Ds2rLas3U`E!7:TBrm1fJd)sN2rlY3>!:B[+!7:_frr;r>s8N/Cs8W)@#li&is2tBAb0'2Q +J,~> +nG`O$L&V,PK`RD;re:@OrIka]Kn]P\s8RfQs+UK,PD/u8s+LLRPPkFfPD+_js+Q1,s+ULOK`M/J +L&_/cPQ1ZHKp.5js+Q1,s+Q1,s+ULOL&_2KKa.R2Ks$-\PPkF\Y5X+Zs+UK,s8RfNrrn,VKn]R, +rIkFTKn]R,PPtL]PPY:aPQ-jHPD+_jre:=N!7q%$!0dD9rr;qNs8N.Ss8W(P#lfU4s+ULQKn]!q +J,~> +nG`NoF8l4>ErgpnrcA)=rGrJKF*%A&s8R0?s)\3]K6."ks)S5@KDb`VK6),6s)W8]s)\5=Erc78 +F8u7QKE(t(F+\Q6s)W8]s)W8]s)\5=F8u:9EsDYcF/!a&KDb`LUAf3<s)\3]s8R0<rrmKDF*%B] +rGr/BF*%B]KDkfMKDPTQKE$T(K6),6rcA&<!7:Ua!/(8lrr;q<s8N.As8W(>#leses)\5?F*$gM +J,~> +nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/<nNd)sN2s2rLas2tB?aoMJ: +b5_JSd/X-mb0\<2s2rLas2rLas2tB?b5_M;ap.mgb1t/,d/<nDh#>G#s2tAas8U7>rrpRFb0'ba +rQ5<Db0'bad/EtEd/*bId/VJmd)sN2rlY3>!:B[+!7:_frr;r>s8N/Cs8W)@#li&is2tBAb0'2Q +J,~> +nG`O$L&V,PK`RD;re:@OrIka]Kn]P\s8RfQs+UK,PD/u8s+LLRPPkFfPD+_js+Q1,s+ULOK`M/J +L&_/QPQ(R`Kp.5irs4>Ys+Q1,s+ULOL&V,KKa.R2Ks(I,PPkF\Y5X+Zs+UK,s8RfNrrn,VKn]R, +rIkFTKn]R,PPtL]PPY:cPQ-jHPD+_jKn]I)!7q%$!0dD9rr;qNs8N.Ss8W(P#QKL3s+ULQL$ntk~> +nG`NoF8l4>ErgpnrcA)=rGrJKF*%A&s8R0?s)\3]K6."ks)S5@KDb`VK6),6s)W8]s)\5=Erc78 +F8u7?KDtlPF+\Q5rs3]Gs)W8]s)\5=F8l49EsDYcF/&]]KDb`LUAf3<s)\3]s8R0<rrmKDF*%B] +rGr/BF*%B]KDkfMKDPTSKE$T(K6),6F*%9Z!7:Ua!/(8lrr;q<s8N.As8W(>#QJjds)\5?F70'Y~> +nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/<nNd)sN2s2rLas2tB?aoMJ: +b5_JAd/O%Hb0\<1rs6dIs2rLas2tB?b5VG;ap.mgb2!$ad/<nDh#>G#s2tAas8U7>rrpRFb0'ba +rQ5<Db0'bad/EtEd/*bKd/VJmd)sN2b0'Y^!:B[+!7:_frr;r>s8N/Cs8W)@#QMrhs2tBAb3o:[~> +nG`O$L&V,PK`RD;re:@OrIkLVKn]P\s8RfOrrRn<L&M&OK`V4;r;R+fs+ULQKn]R,L&_+*!<;hJ +qu6_OPD/o6s+ULQ!/:FPs+UIPrIkCSKn]P\rr3#MPPkFaY5a30s+UFO!/:@N%u(%;L&_1,s+Q1, +Kn]R,PPtL]PPY:cPQ-jHPD+_jKn]I)!7q%$!0dD9rr;qNs8N.Ss8W(P#QKL3s+ULQL$ntk~> +nG`NoF8l4>ErgpnrcA)=rGr5DF*%A&s8R0=rrR7oF8c.=Erl;nr;R+Vs)\5?F*%B]F8u2[!<;h8 +qu6_=K6-qis)\5?!-A/>s)\2>rGr,AF*%A&rr3#GKDb`QUAo:Us)\/=!-A)<%s.blF8u8]s)W8] +F*%B]KDkfMKDPTSKE$T(K6),6F*%9Z!7:Ua!/(8lrr;q<s8N.As8W(>#QJjds)\5?F70'Y~> +nG`OKb5VG@aoTlhrlY6?rQ5BFb0'b,s8U7?rrU?ib5MA?aoVOhr;R,Ns2tBAb0'bab5_F_!<;i: +qu6`?d)u7cs2tBA!6Y<@s2t?@rQ59Cb0'b,rr3#dd/<nIh#GO>s2t<?!6Y6>&'Fppb5_Las2rLa +b0'bad/EtEd/*bKd/VJmd)sN2b0'Y^!:B[+!7:_frr;r>s8N/Cs8W)@#QMrhs2tBAb3o:[~> +nG`O$L&V,PK`RD;re:@Os+LUUL&Zj\rVlkOrVlqQPD/u8s+LLRPPkFfPQ-@:s+Q1,s+ULOK`h@/ +s+UFOs+U@M!elhlqu?\Ms8N(Qrr<"Prr;qN"TO10s+UIP!S3J4rr]G(Kn]F(!/:@N%u(%;L&_1, +s+Q1,Kn]R,PPtL]PPY:bPQ-jHPD+_jL&:lMf)::(s+Q[9L&V,NL&_/SL&_2PKa7X3L&Zl,s+Tn@ +J,~> +nG`NoF8l4>ErgpnrcA)=s)S>CF8p<&rVlk=rVlq?K6."ks)S5@KDb`VKE$#ms)W8]s)\5=Es)G` +s)\/=s)\);!cs!8qu?\;s8N(?rr<">rr;q<"TNOas)\2>!RQJsrr]"qF*%6Y!-A)<%s.blF8u8] +s)W8]F*%B]KDkfMKDPTRKE$T(K6),6F8Pt;d/A"es)WhlF8l4<F8u7AF8u:>EsM_dF8p=]s)[W. +J,~> +nG`OKb5VG@aoTlhrlY6?s2kKEb5]W,rVll?rVlrAd)u=es2kBBd/<nNd/V8gs2rLas2tB?aoh[d +s2t<?s2t6=!m8m4qu?]=s8N)Arr<#@rr;r>"TQWes2t?@!U\83rr_'Vb0'V]!6Y6>&'Fppb5_La +s2rLab0'bad/EtEd/*bJd/VJmd)sN2b5;2=mJY0/s2r^fb5VG>b5_JCb5_M@ap7shb5]Was2sd0 +J,~> +nG`O$L&V,PK`mV>L&Zl+s8RcUs+UK,L&M#OL&M#QKp.5hs8RcRs-*B\!gEY<rr3C\s8RfQs+UK, +s+UK,rVunOqu6_OPD/o6s+ULQ!/:FPs+UIPrIkCSKn]P\rr3#MPPkF_Y5a30qu6YMr;R:]s+Q1, +s+UK,L&Zj\s8S;]rrA8Zrs4hgPQ-i#L&Zl(rrCXKK`_:.PQ$:8s8@ZOrrRoSs8I]Ws+Q1,L&_1, +mf.e~> +nG`NoF8l4>Es.-qF8p=\s8R-Cs)\3]F8c+=F8c+?F+\Q4s8R-@s+C7L!e^Morr3CJs8R0?s)\3] +s)\3]rVun=qu6_=K6-qis)\5?!-A/>s)\2>rGr,AF*%A&rr3#GKDb`OUAo:Uqu6Y;r;R:Ks)W8] +s)\3]F8p<&s8R`Mrr@]Jrs48WKE$RFF8p=YrrCFEEruA_KDorks8@$=rrR9As8I'Es)W8]F8u8] +mf.e~> +nG`OKb5VG@aop)kb5]W`s8U4Es2tAab5M>?b5M>Ab0\<0s8U4Bs3U]D!mptirr3DLs8U7As2tAa +s2tAarVuo?qu6`?d)u7cs2tBA!6Y<@s2t?@rQ59Cb0'b,rr3#dd/<nGh#GO>qu6Z=r;R;Ms2rLa +s2tAab5]W,s8UIErrCFBrs7!Od/VJ8b5]W]rrDHbao_Ucd/M2es8C+?rrU(a)Cs8L.Gs2rLab5_La +mf.e~> +nG`O$L&V,PK`[J<L&CuNK`qF0s+Q1*rr@cOrrRn<L&M&OK`V4;r;Qh^s+UIP%#+`]L&_1,s+UK, +s+UFOs+U@M!elhlqu?\Ms8N(Qrr<"Prr;qN"TO10s+UIP!S3J4rr]G(Kn]4"%u(%;L&_1,s+Q1, +Kn]R,PPtL]PPY:bPQ-jHPD+_jL&:lMf)::(s+Q[9L&V,PKa.R2s8RfQs8I]Ws+Q1,L&_1,mf.e~> +nG`NoF8l4>Erq!oF8Z(<Es2Mas)W8[rr(a)-=rrR7oF8c.=Erl;nr;QhNs)\2>%!2IKF8u8]s)\3] +s)\/=s)\);!cs!8qu?\;s8N(?rr<">rr;q<"TNOas)\2>!RQJsrr]"qF*%$S%s.blF8u8]s)W8] +F*%B]KDkfMKDPTRKE$T(K6),6F8Pt;d/A"es)WhlF8l4>EsDYcs8R0?s8I'Es)W8]F8u8]mf.e~> +nG`OKb5VG@ao]rib5D;>aoqaes2rL_rrC4?rrU?ib5MA?aoVOhr;QiFs2t?@%*JVMb5_Las2tAa +s2t<?s2t6=!m8m4qu?]=s8N)Arr<#@rr;r>"TQWes2t?@!U\83rr_'Vb0'DW&'Fppb5_Las2rLa +b0'bad/EtEd/*bJd/VJmd)sN2b5;2=mJY0/s2r^fb5VG(a)ap.mgs8U7As8L.Gs2rLab5_Lamf.e~> +nG`O$L&V,PK`[J<L&:lRL&Zl,Kn]L*!/:CO!elhlrVunO!WSA]rrSDaL&V)\L&_1,s8RfQL&Zl, +L&M&OL&:lOKp.5fs8RfQrr@cPs8RfPs8@WSs+Q1,L&V)Qes$%3"0VZXL%YHVL&Zj\s8RfQKn]P\ +L&_1:rVlk]qYphbs-*JHKn]P\qu6ZIrIk=QKp2Lirr<"P#60DWs+ULQre:CP"blu1s8Rf@s*t~> +nG`NoF8l4>Erq!oF8Pt@F8p=]F*%<[!-A,=!cs!8rVun=!WRfMrrRiQF8l1JF8u8]s8R0?F8p=] +F8c.=F8Pt=F+\Q2s8R0?rr@->s8R0>s8@!As)W8]F8l1?d"D8r"/>g:F7oPDF8p<&s8R0?F*%A& +F8u8mrVlkMqYphRs+C?(F*%A&qu6ZCrGr&?F+aI5rr<">#6/cEs)\5?rcA,>"`s]bs8R0.s*t~> +nG`OKb5VG@ao]rib5;2Bb5]Wab0'\_!6Y9?!m8m4rVuo?!WUOErrURIb5VDLb5_Las8U7Ab5]Wa +b5MA?b5;2?b0\<.s8U7ArrC4@s8U7@s8C(Cs2rLab5VDAmEke2"5Nq!b4YcFb5]W,s8U7Ab0'b, +b5_LgrVllEqYpiJs3Uemb0'b,qu6Z`rQ53Ab0^.1rr<#@#62jGs2tBArlY9@"j6kfs8U70s*t~> +p]#dES,i?aJ,~> +p]#dES,i?aJ,~> +p]#dES,i?aJ,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4<TETKr2KbWh#Dm~> +o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4<TETKr2KbWh#Dm~> +o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4<TETKr2KbWh#Dm~> +pAY0R<W2suEp<T)j)XYhs&K$t!TS4irr=)<!!((9s8V-ArrC+=s8T+err`=^s/H(ls8Q*krr[9A +<TEWL!35qs!-6lpJ,~> +pAY0R<W2suEp<T)j)XYhs&K$t!TS4irr=)<!!((9s8V-ArrC+=s8T+err`=^s/H(ls8Q*krr[9A +<TEWL!35qs!-6lpJ,~> +pAY0R<W2suEp<T)j)XYhs&K$t!TS4irr=)<!!((9s8V-ArrC+=s8T+err`=^s/H(ls8Q*krr[9A +<TEWL!35qs!-6lpJ,~> +pAY:r3TL.>j6?REj)XYhs&K$t!TS4grrE,"q#C@okPkR_!<3#uWpfrl`rK->EWF/Rs8Q*krrE+[ +n,EEg!8%7$~> +pAY:r3TL.>j6?REj)XYhs&K$t!TS4grrE,"q#C@okPkR_!<3#uWpfrl`rK->EWF/Rs8Q*krrE+[ +n,EEg!8%7$~> +pAY:r3TL.>j6?REj)XYhs&K$t!TS4grrE,"q#C@okPkR_!<3#uWpfrl`rK->EWF/Rs8Q*krrE+[ +n,EEg!8%7$~> +pAY-nEr>qDEo[2[ElS0?<HA*=(33Dqj5Y1#<HA,>WrN+!<HA-"ElV1#qu?[rrVunts8N@b<E6&> +*KF."q>WDSWrN+ZElV1?j&I*?<TF,><E5(ZWiD(ZWrN*Z<H@."s,L*>j)R-[<N?(>j8]."<N?)Z +ElV1?qYpb[!'1'>!36%u%rt[Ms8V+Z<B4(Zs)M+[j8Aogj&H(><TF,><E8)ZElW3#j8AoXWW;ts +s)J7&<N9&>rr3ML<E7*>s2S,[a8b1?<E8)Qs*t~> +pAY-nEr>qDEo[2[ElS0?<HA*=(33Dqj5Y1#<HA,>WrN+!<HA-"ElV1#qu?[rrVunts8N@b<E6&> +*KF."q>WDSWrN+ZElV1?j&I*?<TF,><E5(ZWiD(ZWrN*Z<H@."s,L*>j)R-[<N?(>j8]."<N?)Z +ElV1?qYpb[!'1'>!36%u%rt[Ms8V+Z<B4(Zs)M+[j8Aogj&H(><TF,><E8)ZElW3#j8AoXWW;ts +s)J7&<N9&>rr3ML<E7*>s2S,[a8b1?<E8)Qs*t~> +pAY-nEr>qDEo[2[ElS0?<HA*=(33Dqj5Y1#<HA,>WrN+!<HA-"ElV1#qu?[rrVunts8N@b<E6&> +*KF."q>WDSWrN+ZElV1?j&I*?<TF,><E5(ZWiD(ZWrN*Z<H@."s,L*>j)R-[<N?(>j8]."<N?)Z +ElV1?qYpb[!'1'>!36%u%rt[Ms8V+Z<B4(Zs)M+[j8Aogj&H(><TF,><E8)ZElW3#j8AoXWW;ts +s)J7&<N9&>rr3ML<E7*>s2S,[a8b1?<E8)Qs*t~> +pAY+mrW";dWrE(!s/H(!!!$">ErT,[<?6+[!!#"ZW`<(!WW6$>EiK*>3<6)Ws8Q*ts8Q(,s)K,[ +3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[<TE*[3E6("<<*"Z!<6%!3?;-"NW<'"EcO/?<N?'!WrH'> +<<1(>!!#"Za8>lS<<*%!!$-+[s&C(>!6=+"3E6&Zs&C(>*HM)X&B@cN3E>,"*B?,#rr<$>*EE%; +!NH.u<>smt!$)%>*<<,>WW4&"!<;'Z3B8,[*B@+?WqQIC~> +pAY+mrW";dWrE(!s/H(!!!$">ErT,[<?6+[!!#"ZW`<(!WW6$>EiK*>3<6)Ws8Q*ts8Q(,s)K,[ +3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[<TE*[3E6("<<*"Z!<6%!3?;-"NW<'"EcO/?<N?'!WrH'> +<<1(>!!#"Za8>lS<<*%!!$-+[s&C(>!6=+"3E6&Zs&C(>*HM)X&B@cN3E>,"*B?,#rr<$>*EE%; +!NH.u<>smt!$)%>*<<,>WW4&"!<;'Z3B8,[*B@+?WqQIC~> +pAY+mrW";dWrE(!s/H(!!!$">ErT,[<?6+[!!#"ZW`<(!WW6$>EiK*>3<6)Ws8Q*ts8Q(,s)K,[ +3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[<TE*[3E6("<<*"Z!<6%!3?;-"NW<'"EcO/?<N?'!WrH'> +<<1(>!!#"Za8>lS<<*%!!$-+[s&C(>!6=+"3E6&Zs&C(>*HM)X&B@cN3E>,"*B?,#rr<$>*EE%; +!NH.u<>smt!$)%>*<<,>WW4&"!<;'Z3B8,[*B@+?WqQIC~> +p&?N%WiB&!irH+ZWW<&!NrQ*Z`rM,[!33%!WrF*[<E9&>ErV."WW9(!*QS*Xs&K$ts&BI,EZL2? +s/H(Zs&E(qruqHCs8T)!<W<'!s&E)!s)K-?*?F0?*TP0\`rN.><E8&ZNrAtYWW<%u%03EK!6>+" +<N6%!rrB(rrttfW!-/'[<WC)>a8\/"EZP2[<E7'>N]@*>qYq$*WrN*>*WP."WW6'!EcV*X!NH.u +<>"7k*TI-[rrB)!*EE->!<5&>rVlp>3QLdlJ,~> +p&?N%WiB&!irH+ZWW<&!NrQ*Z`rM,[!33%!WrF*[<E9&>ErV."WW9(!*QS*Xs&K$ts&BI,EZL2? +s/H(Zs&E(qruqHCs8T)!<W<'!s&E)!s)K-?*?F0?*TP0\`rN.><E8&ZNrAtYWW<%u%03EK!6>+" +<N6%!rrB(rrttfW!-/'[<WC)>a8\/"EZP2[<E7'>N]@*>qYq$*WrN*>*WP."WW6'!EcV*X!NH.u +<>"7k*TI-[rrB)!*EE->!<5&>rVlp>3QLdlJ,~> +p&?N%WiB&!irH+ZWW<&!NrQ*Z`rM,[!33%!WrF*[<E9&>ErV."WW9(!*QS*Xs&K$ts&BI,EZL2? +s/H(Zs&E(qruqHCs8T)!<W<'!s&E)!s)K-?*?F0?*TP0\`rN.><E8&ZNrAtYWW<%u%03EK!6>+" +<N6%!rrB(rrttfW!-/'[<WC)>a8\/"EZP2[<E7'>N]@*>qYq$*WrN*>*WP."WW6'!EcV*X!NH.u +<>"7k*TI-[rrB)!*EE->!<5&>rVlp>3QLdlJ,~> +nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTo<W2st<WE(*NZB/#WW<)!<E8nq +('(B7s/H(ZrrB)!<E9)!<<+%[j8W+Zrr35'!<<(!<N6&srrK,"rr3E-Wi?(!s&E(!!9=(ZWr2l* +WW;'"!*-$!s/H)!s8>sts8Q(%WW3$!a8,`C!36)!<E9)!!3-%!q>UJq!;uls<=]$/WrE'>rrB)! +WW<&!Wr;r"j)P-"p&BO~> +nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTo<W2st<WE(*NZB/#WW<)!<E8nq +('(B7s/H(ZrrB)!<E9)!<<+%[j8W+Zrr35'!<<(!<N6&srrK,"rr3E-Wi?(!s&E(!!9=(ZWr2l* +WW;'"!*-$!s/H)!s8>sts8Q(%WW3$!a8,`C!36)!<E9)!!3-%!q>UJq!;uls<=]$/WrE'>rrB)! +WW<&!Wr;r"j)P-"p&BO~> +nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTo<W2st<WE(*NZB/#WW<)!<E8nq +('(B7s/H(ZrrB)!<E9)!<<+%[j8W+Zrr35'!<<(!<N6&srrK,"rr3E-Wi?(!s&E(!!9=(ZWr2l* +WW;'"!*-$!s/H)!s8>sts8Q(%WW3$!a8,`C!36)!<E9)!!3-%!q>UJq!;uls<=]$/WrE'>rrB)! +WW<&!Wr;r"j)P-"p&BO~> +p\u.P<WE*>3<8([WrK(!rrB)!<?9*[WrL+>WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+><E9(!j8U-" +WW<(Z*HM)X(rrWVEiT/>!<<'!WrH(!s8R*[j8Y."<E9%u%`\Ris#F*"!36'ZWrK(!rr3E-WlG+> +iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?<Q>*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t +s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~> +p\u.P<WE*>3<8([WrK(!rrB)!<?9*[WrL+>WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+><E9(!j8U-" +WW<(Z*HM)X(rrWVEiT/>!<<'!WrH(!s8R*[j8Y."<E9%u%`\Ris#F*"!36'ZWrK(!rr3E-WlG+> +iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?<Q>*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t +s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~> +p\u.P<WE*>3<8([WrK(!rrB)!<?9*[WrL+>WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+><E9(!j8U-" +WW<(Z*HM)X(rrWVEiT/>!<<'!WrH(!s8R*[j8Y."<E9%u%`\Ris#F*"!36'ZWrK(!rr3E-WlG+> +iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?<Q>*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t +s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~> +p\t5nr;Zp?WrI,<!!*&t!!92#<W2t"<N6&ts8Q("s/Q%u!lq;@q#:=orW!*BW`<(!*W?'=Wr;u! +*TR(t!$2"<%EGIKs8N)!s&E)!s5P.!!!90#<W2pt3W/pYs&K$u"02C$!<3!-!36'!!!"&>WW<)! +!35tss&BR/WW;)Z<HA+>!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[ +WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~> +p\t5nr;Zp?WrI,<!!*&t!!92#<W2t"<N6&ts8Q("s/Q%u!lq;@q#:=orW!*BW`<(!*W?'=Wr;u! +*TR(t!$2"<%EGIKs8N)!s&E)!s5P.!!!90#<W2pt3W/pYs&K$u"02C$!<3!-!36'!!!"&>WW<)! +!35tss&BR/WW;)Z<HA+>!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[ +WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~> +p\t5nr;Zp?WrI,<!!*&t!!92#<W2t"<N6&ts8Q("s/Q%u!lq;@q#:=orW!*BW`<(!*W?'=Wr;u! +*TR(t!$2"<%EGIKs8N)!s&E)!s5P.!!!90#<W2pt3W/pYs&K$u"02C$!<3!-!36'!!!"&>WW<)! +!35tss&BR/WW;)Z<HA+>!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[ +WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~> +pAY6TWiF,<rs6ZFa2e2[EiS1!rrpHCa8c1[rVuoXs8N8_WoO-Za8#ZHj/T->s8V->s8T+!j8Z+Z +WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z +#fluFWiH+!a/]+<s/Q+Zs8N/@WlOr8!?K5Zrrf@Bs8U.6rrC+<<<2(YrtKM6s5W/>s2V/"a8c2" +WlP/>j/T-Os*t~> +pAY6TWiF,<rs6ZFa2e2[EiS1!rrpHCa8c1[rVuoXs8N8_WoO-Za8#ZHj/T->s8V->s8T+!j8Z+Z +WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z +#fluFWiH+!a/]+<s/Q+Zs8N/@WlOr8!?K5Zrrf@Bs8U.6rrC+<<<2(YrtKM6s5W/>s2V/"a8c2" +WlP/>j/T-Os*t~> +pAY6TWiF,<rs6ZFa2e2[EiS1!rrpHCa8c1[rVuoXs8N8_WoO-Za8#ZHj/T->s8V->s8T+!j8Z+Z +WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z +#fluFWiH+!a/]+<s/Q+Zs8N/@WlOr8!?K5Zrrf@Bs8U.6rrC+<<<2(YrtKM6s5W/>s2V/"a8c2" +WlP/>j/T-Os*t~> +l2LbaWmUhIWW7VMec1.~> +l2LbaWmUhIWW7VMec1.~> +l2LbaWmUhIWW7VMec1.~> +l2Lc)a3jnf`uTa2ec1.~> +l2Lc)a3jnf`uTa2ec1.~> +l2Lc)a3jnf`uTa2ec1.~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +JcCT,J,~> +%%EndData +showpage +%%Trailer +end +%%EOF Added: branches/trunk-reorg/thirdparty/slime/doc/slime-small.pdf =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/thirdparty/slime/doc/slime-small.pdf ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/thirdparty/slime/doc/slime.texi =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/slime.texi 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/slime.texi 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,2471 @@ +\input texinfo +-@c %**start of header +@setfilename slime.info +@settitle The Superior Lisp Interaction Mode for Emacs + +@dircategory Emacs +@direntry +* SLIME: (slime). Superior Lisp Interaction Mode for Emacs. +@end direntry +-@c %**end of header + +@set EDITION 3.0-alpha +@set SLIMEVER 3.0-alpha +@c @set UPDATED @today{} +@set UPDATED @code{$Date: 2007/09/17 13:44:48 $} +@set TITLE SLIME User Manual +@settitle @value{TITLE}, version @value{EDITION} + +@copying +Written by Luke Gorrie. + +Additional contributions: Jeff Cunningham, + +This file has been placed in the public domain. +@end copying + +@titlepage +@title @value{TITLE} +@titlefont{version @value{EDITION}} +@sp 2 +@center @image{slime-small} +@sp 4 +@subtitle Compiled: @value{UPDATED} + +@page +@insertcopying + +@end titlepage + + +@macro SLIME +@acronym{SLIME} +@end macro + +@macro SLDB +@acronym{SLDB} +@end macro + +@macro REPL +@acronym{REPL} +@end macro + +@macro CVS +@acronym{CVS} +@end macro + +@macro kbditem{key, command} +@item \key\ +@itemx M-x \command\ +@kindex \key\ +@findex \command\ +@c +@end macro + +@macro kbditempair{key1, key2, command1, command2} +@item \key1\, M-x \command1\ +@itemx \key2\, M-x \command2\ +@kindex \key1\ +@kindex \key2\ +@findex \command1\ +@findex \command2\ +@c +@end macro + +@macro cmditem{command} +@item M-x \command\ +@findex \command\ +@c +@end macro + +@macro kbdanchorc{key, command, comment} +@anchor{\command\} +@item \key\ +@code{\command\} +@i{\comment\}@* +@end macro + +@macro fcnindex{name} +@item \name\ +@xref{\name\}. +@end macro + +@c @setchapternewpage off +@c @shortcontents +@contents + +@ifnottex +@node Top +@top SLIME + +@SLIME{} is the ``Superior Lisp Interaction Mode for Emacs''. This is +the manual for version @value{SLIMEVER}. + +@insertcopying +@end ifnottex + +@menu +* Introduction:: +* Getting started:: +* slime-mode:: +* REPL:: +* Debugger:: +* Extras:: +* Customization:: +* Tips and Tricks:: +* Credits:: +@c * Index to Functions:: +* Key Index:: +* Command Index:: +* Variable Index:: +@end menu + +@c ----------------------- +@node Introduction +@chapter Introduction + +@SLIME{} is the ``Superior Lisp Interaction Mode for Emacs.'' + +@SLIME{} extends Emacs with support for interactive programming in +Common Lisp. The features are centered around @code{slime-mode}, an +Emacs minor-mode that complements the standard @code{lisp-mode}. While +@code{lisp-mode} supports editing Lisp source files, @code{slime-mode} +adds support for interacting with a running Common Lisp process for +compilation, debugging, documentation lookup, and so on. + +The @code{slime-mode} programming environment follows the example of +Emacs's native Emacs Lisp environment. We have also included good +ideas from similar systems (such as @acronym{ILISP}) and some new +ideas of our own. + +@SLIME{} is constructed from two parts: a user-interface written in +Emacs Lisp, and a supporting server program written in Common +Lisp. The two sides are connected together with a socket and +communicate using an @acronym{RPC}-like protocol. + +The Lisp server is primarily written in portable Common Lisp. The +required implementation-specific functionality is specified by a +well-defined interface and implemented separately for each Lisp +implementation. This makes @SLIME{} readily portable. + +@c ----------------------- +@node Getting started +@chapter Getting started + +This chapter tells you how to get @SLIME{} up and running. + +@menu +* Platforms:: +* Downloading:: +* Installation:: +* Running:: +* Setup Tuning:: +@end menu + +@c ----------------------- +@node Platforms +@section Supported Platforms + +@SLIME{} supports a wide range of operating systems and Lisp +implementations. @SLIME{} runs on Unix systems, Mac OSX, and Microsoft +Windows. GNU Emacs versions 20, 21 and 22 and XEmacs version 21 are +supported. + +The supported Lisp implementations, roughly ordered from the +best-supported, are: + +@itemize @bullet +@item +CMU Common Lisp (@acronym{CMUCL}), 19d or newer +@item +Steel Bank Common Lisp (@acronym{SBCL}), 1.0 or newer +@item +OpenMCL, version 0.14.3 or newer +@item +LispWorks, version 4.3 or newer +@item +Allegro Common Lisp (@acronym{ACL}), version 6 or newer +@item +@acronym{CLISP}, version 2.35 or newer +@item +Armed Bear Common Lisp (@acronym{ABCL}) +@item +Corman Common Lisp (@acronym{CCL}), version 2.51 or newer with the +patches from @url{http://www.grumblesmurf.org/lisp/corman-patches}) +@item +Scieneer Common Lisp (@acronym{SCL}), version 1.2.7 or newer +@end itemize + +Most features work uniformly across implementations, but some are +prone to variation. These include the precision of placing +compiler-note annotations, @acronym{XREF} support, and fancy debugger +commands (like ``restart frame''). + +@c ----------------------- +@node Downloading +@section Downloading SLIME + +You can choose between using a released version of @SLIME{} or +accessing our @CVS{} repository directly. You can download the latest +released version from our website: + +@url{http://www.common-lisp.net/project/slime/} + +We recommend that users who participate in the @code{slime-devel} +mailing list use the @CVS{} version of the code. + +@menu +* CVS:: +* CVS Incantations:: +@end menu + +@c ----------------------- +@node CVS +@subsection Downloading from CVS + +@SLIME{} is available from the @CVS{} repository on +(a)file{common-lisp.net}. You have the option to use either the very +latest code or the tagged @code{FAIRLY-STABLE} snapshot. + +The latest version tends to have more features and fewer bugs than the +@code{FAIRLY-STABLE} version, but it can be unstable during times of +major surgery. As a rule-of-thumb recommendation we suggest that if +you follow the @code{slime-devel} mailing list then you're better off +with the latest version (we'll send a note when it's undergoing major +hacking). If you don't follow the mailing list you won't know the +status of the latest code, so tracking @code{FAIRLY-STABLE} or using a +released version is the safe option. + +If you checkout from @CVS{} then remember to @code{cvs update} +occasionally. Improvements are continually being committed, and the +@code{FAIRLY-STABLE} tag is moved forward from time to time. + +@menu +* CVS Incantations:: +@end menu + +@c ----------------------- +@node CVS Incantations +@subsection CVS incantations + +To download @SLIME{} you first configure your @code{CVSROOT} and login +to the repository. + +@example +export CVSROOT=:pserver:anonymous@@common-lisp.net:/project/slime/cvsroot +cvs login +@end example +@emph{(The password is @code{anonymous})} + +The latest version can then be checked out with: +@example +cvs checkout slime +@end example + +Or the @code{FAIRLY-STABLE} version can be checked out with: + +@example +cvs checkout -rFAIRLY-STABLE slime +@end example + +If you want to find out what's new since the version you're currently +running, you can diff the local @file{ChangeLog} against the +repository version: + +@example +cvs diff -rHEAD ChangeLog # or: -rFAIRLY-STABLE +@end example + +@c ----------------------- +@node Installation +@section Installation + +With a Lisp implementation that can be started from the command-line, +installation just requires a few lines in your @file{~/.emacs}: + +@vindex inferior-lisp-program +@vindex load-path +@example +(setq inferior-lisp-program "@emph{the path to your Lisp system}") +(add-to-list 'load-path "@emph{the path of your @file{slime} directory}") +(require 'slime) +(slime-setup) +@end example + +@iftex +The snippet above also appears in the @file{README} file. You can +copy&paste it from there, but remember to fill in the appropriate +paths. +@end iftex + +We recommend not loading the @acronym{ILISP} package into Emacs if you +intend to use @SLIME{}. Doing so will add a lot of extra bindings to +the keymap for Lisp source files that may be confusing and may not +work correctly for a Lisp process started by @SLIME{}. + +@c ----------------------- +@node Running +@section Running SLIME + +@SLIME{} is started with the Emacs command @kbd{M-x slime}. This uses +the @code{inferior-lisp} package to start a Lisp process, loads and +starts the Lisp-side server (known as ``Swank''), and establishes a +socket connection between Emacs and Lisp. Finally a @REPL{} buffer is +created where you can enter Lisp expressions for evaluation. + +At this point @SLIME{} is up and running and you can start exploring. + +You can restart the @code{inferior-lisp} process using the function: +@table @kbd +@cmditem{slime-restart-inferior-lisp} +@end table + +@node Setup Tuning +@section Setup Tuning + +This section explains ways to reduce @SLIME{}'s startup time and how +to configure @SLIME{} for multiple Lisp systems. + +Please proceed with this section only if your basic setup works. If +you are happy with the basic setup, skip this section. + +@menu +* Autoloading:: +* Multiple Lisps:: +* Loading Swank faster:: +* Loading Contribs:: +@end menu + +@node Autoloading +@subsection Autoloading + +The basic setup loads @SLIME{} always, even if you don't use @SLIME{}. +Emacs will start up a little faster if we load @SLIME{} only on +demand. To achieve that, you have to change your @file{~/.emacs} +slightly: + +@example +(setq inferior-lisp-program "@emph{the path to your Lisp system}") +(add-to-list 'load-path "@emph{the path of your @file{slime} directory}") +(require 'slime-autoloads) +(slime-setup) +@end example + +The only difference compared to the basic setup is the line +@code{(require 'slime-autoloads)}. It tells Emacs that the rest of +@SLIME{} should be loaded when one of the commands @kbd{M-x slime} or +@kbd{M-x slime-connect} is executed the first time. + +@node Multiple Lisps +@subsection Multiple Lisps + +By default, the command @kbd{M-x slime} starts the program specified +with @code{inferior-lisp-program}. If you invoke @kbd{M-x slime} with +a prefix argument, Emacs prompts for the program which should be +started instead. If you need that frequently or if the command +involves long filenames it's more convenient to set the +@code{slime-lisp-implementations} variable in your @file{.emacs}. For +example here we define two programs: + +@vindex slime-lisp-implementations +@lisp +(setq slime-lisp-implementations + '((cmucl ("cmucl" "-quiet")) + (sbcl ("/opt/sbcl/bin/sbcl") :coding-system utf-8-unix))) +@end lisp + +This variable holds a list of programs and if you invoke @SLIME{} with +a negative prefix argument, @kbd{M-- M-x slime}, you can select a +program from that list. The elements of the list should look like + +@lisp +(NAME (PROGRAM PROGRAM-ARGS...) &key CODING-SYSTEM INIT INIT-FUNCTION) +@end lisp + +@table @code +@item NAME +is a symbol and is used to identify the program. +@item PROGRAM +is the filename of the program. Note that the filename can contain +spaces. +@item PROGRAM-ARGS +is a list of command line arguments. +@item CODING-SYSTEM +the coding system for the connection. +@item INIT +@itemx INIT-FUNCTION + ... to be written ... +@end table + +@node Loading Swank faster +@subsection Loading Swank faster + +For SBCL, we recommend that you create a custom core file with socket +support and @acronym{POSIX} bindings included because those modules +take the most time to load. To create such a core, execute the +following steps: + +@example +shell$ sbcl +* (mapc 'require '(sb-bsd-sockets sb-posix sb-introspect sb-cltl2 asdf)) +* (save-lisp-and-die "sbcl.core-for-slime") +@end example + +After that, add something like this to your @file{.emacs}: + +@lisp +(setq slime-lisp-implementations + '((sbcl ("sbcl" "--core" "sbcl.core-for-slime")))) +@end lisp + +For maximum startup speed you can include the Swank server directly in +a core file. The disadvantage of this approach is that the setup is a +bit more involved and that you need to create a new core file when you +want to update @SLIME{} or @acronym{SBCL}. The steps to execute are: + +@example +shell$ sbcl +* (load ".../slime/swank-loader.lisp") +* (save-lisp-and-die "sbcl.core-with-slime") +@end example + +@noindent +Then add this to your @file{.emacs}: + +@lisp +(setq slime-lisp-implementations + '((sbcl ("sbcl" "--core" "sbcl.core-with-slime") + :init (lambda (port-file _) + (format "(swank:start-server %S)\n" port-file))))) +@end lisp + +@noindent +Similar setups should also work for other Lisp implementations. + +@node Loading Contribs +@subsection Loading Contribs +... to be written ... + +@node slime-mode +@chapter Using slime-mode + +@SLIME{}'s commands are provided via @code{slime-mode}, a minor-mode +used in conjunction with Emacs's @code{lisp-mode}. This chapter +describes the @code{slime-mode} and its relatives. + +@menu +* User-interface conventions:: +* Key bindings:: +* Commands:: +* Semantic indentation:: +* Reader conditionals:: +@end menu + +@c ----------------------- +@node User-interface conventions +@section User-interface conventions + +To use @SLIME{} comfortably it is important to understand a few +``global'' user-interface characteristics. The most important +principles are described in this section. + +@menu +* Temporary buffers:: +* Inferior-lisp:: +* Multithreading:: +@end menu + +@c ----------------------- +@node Temporary buffers +@subsection Temporary buffers + +Some @SLIME{} commands create temporary buffers to display their +results. Although these buffers usually have their own special-purpose +major-modes, certain conventions are observed throughout. + +Temporary buffers can be dismissed by pressing @kbd{q}. This kills the +buffer and restores the window configuration as it was before the +buffer was displayed. Temporary buffers can also be killed with the +usual commands like @code{kill-buffer}, in which case the previous +window configuration won't be restored. + +Pressing @kbd{RET} is supposed to ``do the most obvious useful +thing.'' For instance, in an apropos buffer this prints a full +description of the symbol at point, and in an @acronym{XREF} buffer it +displays the source code for the reference at point. This convention +is inherited from Emacs's own buffers for apropos listings, +compilation results, etc. + +Temporary buffers containing Lisp symbols use @code{slime-mode} in +addition to any special mode of their own. This makes the usual +@SLIME{} commands available for describing symbols, looking up +function definitions, and so on. + +@c ----------------------- +@node Inferior-lisp +@subsection @code{*inferior-lisp*} buffer + +@SLIME{} internally uses the @code{comint} package to start Lisp +processes. This has a few user-visible consequences, some good and +some not-so-terribly. To avoid confusion it is useful to understand +the interactions. + +The buffer @code{*inferior-lisp*} contains the Lisp process's own +top-level. This direct access to Lisp is useful for troubleshooting, +and some degree of @SLIME{} integration is available using the +@code{inferior-slime-mode}. However, in normal use we recommend using +the fully-integrated @SLIME{} @REPL{} and ignoring the +@code{*inferior-lisp*} buffer. + +@c ----------------------- +@node Multithreading +@subsection Multithreading + +If the Lisp system supports multithreading, SLIME spawns a new thread +for each request, e.g., @kbd{C-x C-e} creates a new thread to evaluate +the expression. An exception to this rule are requests from the +@REPL{}: all commands entered in the @REPL{} buffer are evaluated in a +dedicated @REPL{} thread. + +Some complications arise with multithreading and special variables. +Non-global special bindings are thread-local, e.g., changing the value +of a let bound special variable in one thread has no effect on the +binding of the variables with the same name in other threads. This +makes it sometimes difficult to change the printer or reader behaviour +for new threads. The variable +@code{swank:*default-worker-thread-bindings*} was introduced for such +situtuations: instead of modifying the global value of a variable, add a +binding the @code{swank:*default-worker-thread-bindings*}. E.g., with +the following code, new threads will read floating point values as +doubles by default: + +@example +(push '(*read-default-float-format* . double-float) + swank:*default-worker-thread-bindings*). +@end example + +@c ----------------------- +@node Key bindings +@section Key bindings + +@quotation +@i{``Are you deliberately spiting Emacs's brilliant online help facilities? The gods will be angry!''} +@end quotation + +@noindent This is a brilliant piece of advice. The Emacs online help facilities +are your most immediate, up-to-date and complete resource for keybinding +information. They are your friends: + +@table @kbd +@kbdanchorc{C-h k <key>, describe-key, ``What does this key do?''} +Describes current function bound to @kbd{<key>} for focus buffer. + +@kbdanchorc{C-h b, describe-bindings, ``Exactly what bindings are available?''} +Lists the current key-bindings for the focus buffer. + +@kbdanchorc{C-h m, describe-mode, ``Tell me all about this mode''} +Shows all the available major mode keys, then the minor mode keys, for +the modes of the focus buffer. + +@kbdanchorc{C-h l, view-lossage, ``Woah@comma{} what key chord did I just do?''} +Shows you the literal sequence of keys you've pressed in order. + + +@c <key> is breaks links PDF, despite that it's not l it's C-h +@c @kbdanchorc{ <key> l, , ``What starts with?''} +@c Lists all keybindings that begin with @code{<key>} for the focus buffer mode. + + +@end table + +@emph{Note:} In this documentation the designation @kbd{C-h} is a +@dfn{cannonical key} which might actually mean Ctrl-h, or F1, or +whatever you have @code{help-command} bound to in your +(a)code{.emacs}. Here is a common situation: + +@example +(global-set-key [f1] 'help-command) +(global-set-key "\C-h" 'delete-backward-char) +@end example + +@noindent In this situation everywhere you see @kbd{C-h} in the +documentation you would substitute @kbd{F1}. + +In general we try to make our key bindings fit with the overall Emacs +style. We also have the following somewhat unusual convention of our +own: when entering a three-key sequence, the final key can be pressed +either with control or unmodified. For example, the +@code{slime-describe-symbol} command is bound to @kbd{C-c C-d d}, but +it also works to type @kbd{C-c C-d C-d}. We're simply binding both key +sequences because some people like to hold control for all three keys +and others don't, and with the two-key prefix we're not afraid of +running out of keys. + +There is one exception to this rule, just to trip you up. We never +bind @kbd{C-h} anywhere in a key sequence, so @kbd{C-c C-d C-h} +doesn't do the same thing as @kbd{C-c C-d h}. This is because Emacs +has a built-in default so that typing a prefix followed by @kbd{C-h} +will display all bindings starting with that prefix, so @kbd{C-c C-d +C-h} will actually list the bindings for all documentation commands. +This feature is just a bit too useful to clobber! + +You can assign or change default key bindings globally using the +@code{global-set-key} function in your @file{~/.emacs} file like this: +@example +(global-set-key "\C-c s" 'slime-selector) +@end example +@noindent +which binds @kbd{C-c s} to the function @code{slime-selector}. + +Alternatively, if you want to assign or change a key binding in just a +particular slime mode, you can use the @code{global-set-key} function +in your @file{~/.emacs} file like this: +@example +(define-key slime-repl-mode-map (kbd "C-c ;") + 'slime-insert-balanced-comments) +@end example +@noindent +which binds @kbd{C-c ;} to the function +@code{slime-insert-balanced-comments} in the REPL buffer. + +@c ----------------------- +@node Commands +@section Commands + +@acronym{SLIME} commands are divided into the following general +categories: @strong{Programming, Compilation, Evaluation, Recovery, +Inspector, and Profiling}, discussed in separate sections below. There +are also comprehensive indices to commands by function +(@pxref{Command Index}). + +@menu +* Programming:: +* Compilation:: +* Evaluation:: +* Recovery:: +* Inspector:: +* Profiling:: +* Other:: +@end menu + +@c ----------------------- +@node Programming +@subsection Programming commands + +Programming commands are divided into the following categories: +@strong{Completion, Documentation, Cross-reference, Finding +definitions, Macro-expansion, and Disassembly}, discussed in +separate sections below. + +@menu +* Completion:: +* Closure:: +* Indentation:: +* Documentation:: +* Cross-reference:: +* Finding definitions:: +* Macro-expansion:: +* Disassembly:: +@end menu + +@c ----------------------- +@node Completion +@subsubsection Completion commands + +Completion commands are used to complete a symbol or form based on +what is already present at point. Classical completion assumes an +exact prefix and gives choices only where branches may occur. Fuzzy +completion tries harder. + +@table @kbd +@kbditem{M-TAB,slime-complete-symbol} +@itemx ESC TAB +@itemx C-c C-i +@itemx C-M-i +Complete the symbol at point. Note that three styles of completion are +available in @SLIME{}, and the default differs from normal Emacs +completion (@pxref{slime-complete-symbol-function}). + +@kbditem{C-c C-s, slime-complete-form} +Looks up and inserts into the current buffer the argument list for the +function at point, if there is one. More generally, the command +completes an incomplete form with a template for the missing arguments. +There is special code for discovering extra keywords of generic +functions and for handling @code{make-instance} and +@code{defmethod}. Examples: + +@example +(subseq "abc" <C-c C-s> + --inserts--> start [end]) +(find 17 <C-c C-s> + --inserts--> sequence :from-end from-end :test test + :test-not test-not :start start :end end + :key key) +(find 17 '(17 18 19) :test #'= <C-c C-s> + --inserts--> :from-end from-end + :test-not test-not :start start :end end + :key key) +(defclass foo () ((bar :initarg :bar))) +(defmethod print-object <C-c C-s> + --inserts--> (object stream) + body...) +(defmethod initialize-instance :after ((object foo) &key blub)) +(make-instance 'foo <C-c C-s> + --inserts--> :bar bar :blub blub initargs...) +@end example + +@anchor{slime-fuzzy-complete-symbol} +@kbditem{C-c M-i, slime-fuzzy-complete-symbol} +Presents a list of likely completions to choose from for an +abbreviation at point. This is a third completion method and it is +very different from the more traditional completion to which +@command{slime-complete-symbol} defaults. It attempts to complete a +symbol all at once, instead of in pieces. For example, ``mvb'' will +find ``@code{multiple-value-bind}'' and ``norm-df'' will find +``@code{least-positive-normalized-double-float}''. This can also be +selected as the method of completion used for +@code{slime-complete-symbol}. + +@cmditem{slime-fuzzy-completions-mode} +@cmditem{slime-fuzzy-abort} +@end table + + +@c ----------------------- +@node Closure +@subsubsection Closure commands + +Closure commands are used to fill in missing parenthesis. + +@table @kbd +@kbditem{C-c C-q, slime-close-parens-at-point} +Closes parentheses at point to complete the top-level-form by inserting ')' +characters at until @code{beginning-of-defun} and @code{end-of-defun} +execute without errors, or @code{slime-close-parens-limit} is exceeded. + +@kbditem{C-], slime-close-all-sexp} +Balance parentheses of open s-expressions at point. +Insert enough right-parentheses to balance unmatched left-parentheses. +Delete extra left-parentheses. Reformat trailing parentheses +Lisp-stylishly. + +If @code{REGION} is true, operate on the region. Otherwise operate on +the top-level sexp before point. +@end table + + +@c ----------------------- +@node Indentation +@subsubsection Indentation commands + +@table @kbd +@kbditem{C-c M-q, slime-reindent-defun} +Re-indents the current defun, or refills the current paragraph. +If point is inside a comment block, the text around point will be +treated as a paragraph and will be filled with @code{fill-paragraph}. +Otherwise, it will be treated as Lisp code, and the current defun +will be reindented. If the current defun has unbalanced parens, +an attempt will be made to fix it before reindenting. + +@kbditem{C-M-q, indent-sexp} +Indents the list immediately following point to match the level at point. + +When given a prefix argument, the text around point will always +be treated as a paragraph. This is useful for filling docstrings." +@end table + + +@c ----------------------- +@node Documentation +@subsubsection Documentation commands + +@SLIME{}'s online documentation commands follow the example of Emacs +Lisp. The commands all share the common prefix @kbd{C-c C-d} and allow +the final key to be modified or unmodified (@pxref{Key bindings}.) + +@table @kbd + +@kbditem{SPC, slime-space} +The space key inserts a space, but also looks up and displays the +argument list for the function at point, if there is one. + +@kbditem{C-c C-d d, slime-describe-symbol} +Describe the symbol at point. + +@kbditem{C-c C-f, slime-describe-function} +Describe the function at point. + +@kbditem{C-c C-d a, slime-apropos} +Perform an apropos search on Lisp symbol names for a regular expression +match and display their documentation strings. By default the external +symbols of all packages are searched. With a prefix argument you can choose a +specific package and whether to include unexported symbols. + +@kbditem{C-c C-d z, slime-apropos-all} +Like @code{slime-apropos} but also includes internal symbols by default. + +@kbditem{C-c C-d p, slime-apropos-package} +Show apropos results of all symbols in a package. This command is for +browsing a package at a high-level. With package-name completion it +also serves as a rudimentary Smalltalk-ish image-browser. + +@kbditem{C-c C-d h, slime-hyperspec-lookup} +Lookup the symbol at point in the @cite{Common Lisp Hyperspec}. This +uses the familiar @file{hyperspec.el} to show the appropriate section +in a web browser. The Hyperspec is found either on the Web or in +@code{common-lisp-hyperspec-root}, and the browser is selected by +@code{browse-url-browser-function}. + +Note: this is one case where @kbd{C-c C-d h} is @emph{not} the same as +@kbd{C-c C-d C-h}. + +@kbditem{C-c C-d ~, common-lisp-hyperspec-format} +Lookup a @emph{format character} in the @cite{Common Lisp Hyperspec}. +@end table + + +@c ----------------------- +@node Cross-reference +@subsubsection Cross-reference commands + +@SLIME{}'s cross-reference commands are based on the support provided +by the Lisp system, which varies widely between Lisps. For systems +with no built-in @acronym{XREF} support @SLIME{} queries a portable +@acronym{XREF} package, which is taken from the @cite{CMU AI +Repository} and bundled with @SLIME{}. + +Each command operates on the symbol at point, or prompts if there is +none. With a prefix argument they always prompt. You can either enter +the key bindings as shown here or with the control modified on the +last key, @xref{Key bindings}. + +@table @kbd +@kbditem{C-c C-w c, slime-who-calls} +Show function callers. + +@kbditem{C-c C-w w, slime-calls-who} +Show all known callees. + +@kbditem{C-c C-w r, slime-who-references} +Show references to global variable. + +@kbditem{C-c C-w b, slime-who-binds} +Show bindings of a global variable. + +@kbditem{C-c C-w s, slime-who-sets} +Show assignments to a global variable. + +@kbditem{C-c C-w m, slime-who-macroexpands} +Show expansions of a macro. + +@cmditem{slime-who-specializes} +Show all known methods specialized on a class. + +@end table + +There are also ``List callers/callees'' commands. These operate by +rummaging through function objects on the heap at a low-level to +discover the call graph. They are only available with some Lisp +systems, and are most useful as a fallback when precise @acronym{XREF} +information is unavailable. + +@table @kbd +@kbditem{C-c <, slime-list-callers} +List callers of a function. + +@kbditem{C-c >, slime-list-callees} +List callees of a function. + +@end table + + + +@c ----------------------- +@node Finding definitions +@subsubsection Finding definitions (``Meta-Point'' commands). + +The familiar @kbd{M-.} command is provided. For generic functions this +command finds all methods, and with some systems it does other fancy +things (like tracing structure accessors to their @code{DEFSTRUCT} +definition). + +@table @kbd + +@kbditem{M-., slime-edit-definition} +Go to the definition of the symbol at point. + +@item M-, +@itemx M-* +@itemx M-x slime-pop-find-definition-stack +@kindex M-, +@findex slime-pop-find-definition-stack +Go back to the point where @kbd{M-.} was invoked. This gives multi-level +backtracking when @kbd{M-.} has been used several times. + +@kbditem{C-x 4 ., slime-edit-definition-other-window} +Like @code{slime-edit-definition} but switchs to the other window to +edit the definition in. + +@kbditem{C-x 5 ., slime-edit-definition-other-frame} +Like @code{slime-edit-definition} but opens another frame to edit the +definition in. + +@cmditem{slime-edit-definition-with-etags} +Use an ETAGS table to find definition at point. + +@end table + +@c ----------------------- +@node Macro-expansion +@subsubsection Macro-expansion commands + +@table @kbd +@kbditem{C-c C-m, slime-macroexpand-1} +Macroexpand the expression at point once. If invoked with a prefix +argument, use macroexpand instead of macroexpand-1. + +@kbditem{C-c M-m, slime-macroexpand-all} +Fully macroexpand the expression at point. + +@cmditem{slime-compiler-macroexpand-1} +Display the compiler-macro expansion of sexp at point. + +@cmditem{slime-compiler-macroexpand} +Repeatedy expamd compiler macros of sexp at point. + +@end table + +For additional minor-mode commands and discussion, +@pxref{slime-macroexpansion-minor-mode}. + + +@c ----------------------- +@node Disassembly +@subsubsection Disassembly commands + +@table @kbd + +@kbditem{C-c M-d, slime-disassemble-symbol} +Disassemble the function definition of the symbol at point. + +@kbditem{C-c C-t, slime-toggle-trace-fdefinition} +Toggle tracing of the function at point. If invoked with a prefix +argument, read additional information, like which particular method +should be traced. + +@cmditem{slime-untrace-all} +Untrace all functions. + +@end table + +@c ----------------------- +@node Compilation +@subsection Compilation commands + +@SLIME{} has fancy commands for compiling functions, files, and +packages. The fancy part is that notes and warnings offered by the +Lisp compiler are intercepted and annotated directly onto the +corresponding expressions in the Lisp source buffer. (Give it a try to +see what this means.) + +@table @kbd +@kbditem{C-c C-c, slime-compile-defun} +Compile the top-level form at point. +@cindex compiling functions + +@kbditem{C-c C-y, slime-call-defun} +Insert a call to the function defined around point into the REPL. + +@kbditem{C-c C-k, slime-compile-and-load-file} +Compile and load the current buffer's source file. + +@kbditem{C-c M-k, slime-compile-file} +Compile (but don't load) the current buffer's source file. + +@kbditem{C-c C-l, slime-load-file} +Load a source file and compile if necessary, without loading into a buffer.. + +@kbditem{C-c C-z, slime-switch-to-output-buffer} +Select the output buffer, preferably in a different window. + +@cmditem{slime-compile-region} +Compile region at point. + +@end table + +The annotations are indicated as underlining on source forms. The +compiler message associated with an annotation can be read either by +placing the mouse over the text or with the selection commands below. + +@table @kbd +@kbditem{M-n, slime-next-note} +Move the point to the next compiler note and displays the note. + +@kbditem{M-p, slime-previous-note} +Move the point to the previous compiler note and displays the note. + +@kbditem{C-c M-c, slime-remove-notes} +Remove all annotations from the buffer. +@end table + +@c ----------------------- +@node Evaluation +@subsection Evaluation commands + +These commands each evaluate a Lisp expression in a different way. By +default they show their results in a message, but a prefix argument +causes the results to be printed in the @REPL{} instead. + +@table @kbd + +@kbditem{C-M-x, slime-eval-defun} +Evaluate the current toplevel form. +Use @code{slime-re-evaluate-defvar} if the from starts with @code{(defvar}. + +@kbditem{C-x C-e, slime-eval-last-expression} +Evaluate the expression before point. +@end table + +If @kbd{C-M-x} or @kbd{C-x C-e} is given a numeric argument, it inserts the +value into the current buffer at point, rather than displaying it in the +echo area. + +@table @kbd +@kbditem{C-c C-p, slime-pprint-eval-last-expression} +Evaluate the expression before point and pretty-print the result. + +@kbditem{C-c C-r, slime-eval-region} +Evaluate the region. + +@kbditem{C-x M-e, slime-eval-last-expression-display-output} +Display output buffer and evaluate the expression preceding point. + +@kbditem{C-c :, slime-interactive-eval} +Evaluate an expression read from the minibuffer. + +@anchor{slime-scratch} +@cmditem{slime-scratch} +Create a @file{*slime-scratch*} buffer. In this +buffer you can enter Lisp expressions and evaluate them with +@kbd{C-j}, like in Emacs's @file{*scratch*} buffer. + +@kbditem{C-c E, slime-edit-value} +Edit the value of a setf-able form in a new buffer @file{*Edit <form>*}. +The value is inserted into a temporary buffer for editing and then set +in Lisp when committed with @code{slime-edit-value-commit}. + +@kbditem{C-c C-u, slime-undefine-function} +Unbind symbol for function at point. +@end table + + +@c ----------------------- +@node Recovery +@subsection Abort/Recovery commands + +@table @kbd +@kbditem{C-c C-b, slime-interrupt} +Interrupt Lisp (send @code{SIGINT}). + +@kbditem{C-c ~, slime-sync-package-and-default-directory} +Synchronize the current package and working directory from Emacs to +Lisp. + +@kbditem{C-c M-p, slime-repl-set-package} +Set the current package of the @acronym{REPL}. + +@end table + +@c ----------------------- +@node Inspector +@subsection Inspector commands + +The @SLIME{} inspector is a very fancy Emacs-based alternative to the +standard @code{INSPECT} function. The inspector presents objects in +Emacs buffers using a combination of plain text, hyperlinks to related +objects, and ``actions'' that can be selected to invoke Lisp code on +the inspected object. For example, to present a generic function the +inspector shows the documentation in plain text and presents each +method with both a hyperlink to inspect the method object and a +``remove method'' action that you can invoke interactively. + +The inspector can easily be specialized for the objects in your own +programs. For details see the the @code{inspect-for-emacs} generic +function in @file{swank-backend.lisp}. + +@table @kbd + +@kbditem{C-c I, slime-inspect} +Inspect the value of an expression entered in the minibuffer. + +@end table + +The standard commands available in the inspector are: + +@table @kbd + +@kbditem{RET, slime-inspector-operate-on-point} +If point is on a value then recursivly call the inspcetor on that +value. If point is on an action then call that action. + +@kbditem{d, slime-inspector-describe} +Describe the slot at point. + +@kbditem{l, slime-inspector-pop} +Go back to the previous object (return from @kbd{RET}). + +@kbditem{n, slime-inspector-next} +The inverse of @kbd{l}. Also bound to @kbd{SPC}. + +@kbditem{q, slime-inspector-quit} +Dismiss the inspector buffer. + +@kbditem{M-RET, slime-inspector-copy-down} +Evaluate the value under point via the REPL (to set `*'). + +@end table + +@c ----------------------- +@node Profiling +@subsection Profiling commands + +@table @kbd +@cmditem{slime-toggle-profile-fdefinition} +Toggle profiling of a function. +@cmditem{slime-profile-package} +Profile all functions in a package. +@cmditem{slime-unprofile-all} +Unprofile all functions. +@cmditem{slime-profile-report} +Report profiler data. +@cmditem{slime-profile-reset} +Reset profiler data. +@cmditem{slime-profiled-functions} +Show list of currently profiled functions. +@end table + +@c ----------------------- +@node Other +@subsection Shadowed Commands + +@table @kbd + +@kbditempair{C-c C-a, C-c C-v, slime-nop, slime-nop} +This key-binding is shadowed from inf-lisp. + +@end table + +@c ----------------------- +@node Semantic indentation +@section Semantic indentation + +@SLIME{} automatically discovers how to indent the macros in your Lisp +system. To do this the Lisp side scans all the macros in the system and +reports to Emacs all the ones with @code{&body} arguments. Emacs then +indents these specially, putting the first arguments four spaces in and +the ``body'' arguments just two spaces, as usual. + +This should ``just work.'' If you are a lucky sort of person you needn't +read the rest of this section. + +To simplify the implementation, @SLIME{} doesn't distinguish between +macros with the same symbol-name but different packages. This makes it +fit nicely with Emacs's indentation code. However, if you do have +several macros with the same symbol-name then they will all be indented +the same way, arbitrarily using the style from one of their +arglists. You can find out which symbols are involved in collisions +with: + +@example +(swank:print-indentation-lossage) +@end example + +If a collision causes you irritation, don't have a nervous breakdown, +just override the Elisp symbol's @code{common-lisp-indent-function} +property to your taste. @SLIME{} won't override your custom settings, it +just tries to give you good defaults. + +A more subtle issue is that imperfect caching is used for the sake of +performance. @footnote{@emph{Of course} we made sure it was actually too +slow before making the ugly optimization.} + +In an ideal world, Lisp would automatically scan every symbol for +indentation changes after each command from Emacs. However, this is too +expensive to do every time. Instead Lisp usually just scans the symbols +whose home package matches the one used by the Emacs buffer where the +request comes from. That is sufficient to pick up the indentation of +most interactively-defined macros. To catch the rest we make a full scan +of every symbol each time a new Lisp package is created between commands +-- that takes care of things like new systems being loaded. + +You can use @kbd{M-x slime-update-indentation} to force all symbols to +be scanned for indentation information. + +@c ----------------------- +@node Reader conditionals +@section Reader conditional fontification + +@SLIME{} automatically evaluates reader-conditional expressions in +source buffers and ``grays out'' code that will be skipped for the +current Lisp connection. + + +@c ----------------------- +@node REPL +@chapter REPL: the ``top level'' + +@SLIME{} uses a custom Read-Eval-Print Loop (@REPL{}, also known as a +``top level''). The @REPL{} user-interface is written in Emacs Lisp, +which gives more Emacs-integration than the traditional +@code{comint}-based Lisp interaction: + +@itemize @bullet +@item +Conditions signalled in @REPL{} expressions are debugged with @SLDB{}. +@item +Return values are distinguished from printed output by separate Emacs +faces (colours). +@item +Emacs manages the @REPL{} prompt with markers. This ensures that Lisp +output is inserted in the right place, and doesn't get mixed up with +user input. +@end itemize + +@menu +* REPL commands:: +* Input Navigation:: +* Shortcuts:: +@end menu + +@c ----------------------- +@node REPL commands +@section REPL commands + +@table @kbd + +@kbditem{RET, slime-repl-return} +Evaluate the current input in Lisp if it is complete. If incomplete, +open a new line and indent. If a prefix argument is given then the +input is evaluated without checking for completeness. + +@kbditem{C-RET, slime-repl-closing-return} +Close any unmatched parenthesis and then evaluate the current input in +Lisp. Also bound to @kbd{M-RET}. + +@kbditem{C-j, slime-repl-newline-and-indent} +Open and indent a new line. + +@c @anchor{slime-interrupt} +@kbditem{C-c C-c, slime-interrupt} +Interrupt the Lisp process with @code{SIGINT}. + +@kbditem{C-c M-g, slime-quit} +Quit slime. + +@kbditem{C-c C-o, slime-repl-clear-output} +Remove the output and result of the previous expression from the +buffer. + +@kbditem{C-c C-t, slime-repl-clear-buffer} +Clear the entire buffer, leaving only a prompt. + +@end table + +@c ----------------------- +@node Input Navigation +@section Input navigation + +@table @kbd + +@kbditem{C-a, slime-repl-bol} +Go to the beginning of the line, but stop at the @REPL{} prompt. + +@kbditempair{M-n, M-p, slime-repl-next-input, slime-repl-previous-input} +Go to next/previous in command history. + +@kbditempair{M-s, M-r, +slime-repl-next-matching-input, slime-repl-previous-matching-input} +Search forward/reverse through command history with regex + +@c @code{slime-repl-@{next,previous@}-input}@* +@c @code{slime-repl-@{next,previous@}-matching-input}@* +@c @code{comint}-style input history commands. + +@kbditempair{C-c C-n, C-c C-p, +slime-repl-next-prompt, slime-repl-previous-prompt} +Move between the current and previous prompts in the @REPL{} buffer. + +@kbditempair{C-M-a, C-M-e, +slime-repl-beginning-of-defun, slime-repl-end-of-defun} +These commands are like @code{beginning-of-defun} and +@code{end-of-defun}, but when used inside the @REPL{} input area they +instead go directly to the beginning or the end, respectively. + +@end table + +@c ----------------------- +@comment node-name, next, previous, up +@node Shortcuts +@section Shortcuts + +``Shortcuts'' are a special set of @REPL{} commands that are invoked +by name. To invoke a shortcut you first press @kbd{,} (comma) at the +@REPL{} prompt and then enter the shortcut's name when prompted. + +Shortcuts deal with things like switching between directories and +compiling and loading Lisp systems. The set of shortcuts is listed +below, and you can also use the @code{help} +shortcut to list them interactively. + +@table @kbd +@item change-directory (aka !d, cd) +Change the current directory. + +@item change-package (aka !p) +Change the current package. + +@item compile-and-load (aka cl) +Compile (if neccessary) and load a lisp file. + +@item compile-system +Compile (but not load) an ASDF system. + +@item defparameter (aka !) +Define a new global, special, variable. + +@item force-compile-system +Recompile (but not load) an ASDF system. + +@item force-load-system +Recompile and load an ASDF system. + +@item help (aka ?) +Display the help. + +@item load-system +Compile (as needed) and load an ASDF system. + +@item pop-directory (aka -d) +Pop the current directory. + +@item pop-package (aka -p) +Pop the top of the package stack. + +@item push-directory (aka +d, pushd) +Push a new directory onto the directory stack. + +@item push-package (aka +p) +Push a package onto the package stack. + +@item pwd +Show the current directory. + +@item quit +Quit the current Lisp. + +@item resend-form +Resend the last form. + +@item restart-inferior-lisp +Restart *inferior-lisp* and reconnect SLIME. + +@item sayoonara +Quit all Lisps and close all SLIME buffers. + +@end table + +@c ----------------------- +@node Debugger +@chapter SLDB: the SLIME debugger + +@SLIME{} has a custom Emacs-based debugger called @SLDB{}. Conditions +signalled in the Lisp system invoke @SLDB{} in Emacs by way of the +Lisp @code{*DEBUGGER-HOOK*}. + +@SLDB{} pops up a buffer when a condition is signalled. The buffer +displays a description of the condition, a list of restarts, and a +backtrace. Commands are offered for invoking restarts, examining the +backtrace, and poking around in stack frames. + +@menu +* Examining frames:: +* Restarts:: +* Frame Navigation:: +* Miscellaneous:: +@end menu + +@c ----------------------- +@node Examining frames +@section Examining frames + +Commands for examining the stack frame at point. + +@table @kbd +@kbditem{t, sldb-toggle-details} +Toggle display of local variables and @code{CATCH} tags. + +@kbditem{v, sldb-show-source} +View the frame's current source expression. The expression is +presented in the Lisp source file's buffer. + +@kbditem{e, sldb-eval-in-frame} +Evaluate an expression in the frame. The expression can refer to the +available local variables in the frame. + +@kbditem{d, sldb-pprint-eval-in-frame} +Evaluate an expression in the frame and pretty-print the result in a +temporary buffer. + +@kbditem{D, sldb-disassemble} +Disassemble the frame's function. Includes information such as the +instruction pointer within the frame. + +@kbditem{i, sldb-inspect-in-frame} +Inspect the result of evaluating an expression in the frame. +@end table + +@c ----------------------- +@node Restarts +@section Invoking restarts + +@table @kbd +@kbditem{a, sldb-abort} +Invoke the @code{ABORT} restart. + +@kbditem{q, sldb-quit} +``Quit'' -- @code{THROW} to a tag that the top-level @SLIME{} +request-loop catches. + +@kbditem{c, sldb-continue} +Invoke the @code{CONTINUE} restart. + +@item 0 ... 9 +Invoke a restart by number. +@end table + +Restarts can also be invoked by pressing @kbd{RET} or @kbd{Mouse-2} on +them in the buffer. + +@c ----------------------- +@node Frame Navigation +@section Navigating between frames + +@table @kbd +@kbditempair{n,p,sldb-down,sldb-up} +Move between frames. + +@kbditempair{M-n, M-p, sldb-details-down, sldb-details-up} +Move between frames ``with sugar'': hide the details of the original +frame and display the details and source code of the next. Sugared +motion makes you see the details and source code for the current frame +only. +@end table + +@c ----------------------- +@node Miscellaneous +@section Miscellaneous Commands + +@table @kbd +@kbditem{r, sldb-restart-frame} +Restart execution of the frame with the same arguments it was +originally called with. (This command is not available in all +implementations.) + +@kbditem{R, sldb-return-from-frame} +Return from the frame with a value entered in the minibuffer. (This +command is not available in all implementations.) + +@kbditem{s, sldb-step} +Step to the next expression in the frame. (This command is not +available in all implementations.) + +@kbditem{B, sldb-break-with-default-debugger} +Exit @SLDB{} and debug the condition using the Lisp system's default +debugger. + +@kbditem{C-c :, slime-interactive-eval} +Evaluate an expression entered in the minibuffer. +@end table + + +@c ----------------------- +@node Extras +@chapter Extras + +@menu +* slime-selector:: +* slime-autodoc-mode:: +* slime-macroexpansion-minor-mode:: +* Multiple connections:: +* Typeout frames:: +@end menu + +@c ----------------------- +@node slime-selector +@section @code{slime-selector} + +The @code{slime-selector} command is for quickly switching to +important buffers: the @REPL{}, @SLDB{}, the Lisp source you were just +hacking, etc. Once invoked the command prompts for a single letter to +specify which buffer it should display. Here are some of the options: + +@table @kbd +@item ? +A help buffer listing all @code{slime-selectors}'s available buffers. +@item r +The @REPL{} buffer for the current @SLIME{} connection. +@item d +The most recently activated @SLDB{} buffer for the current connection. +@item l +The most recently visited @code{lisp-mode} source buffer. +@item s +The @code{*slime-scratch*} buffer (@pxref{slime-scratch}). +@end table + +@code{slime-selector} doesn't have a key binding by default but we +suggest that you assign it a global one. You can bind it to @kbd{C-c s} +like this: + +@example +(global-set-key "\C-cs" 'slime-selector) +@end example + +@noindent +And then you can switch to the @REPL{} from anywhere with @kbd{C-c s +r}. + +The macro @code{def-slime-selector-method} can be used to define new +buffers for @code{slime-selector} to find. + +@c ----------------------- +@node slime-autodoc-mode +@section @code{slime-autodoc-mode} + +@table @kbd +@cmditem{slime-autodoc-mode} +Autodoc mode is an additional minor-mode for automatically showing +information about symbols near the point. For function names the +argument list is displayed, and for global variables, the value. +This is a clone of @code{eldoc-mode} for Emacs Lisp. +@end table + +The mode can be enabled by default in the @code{slime-setup} call of your +(a)code{~/.emacs}: +@example +(slime-setup '(slime-autodoc)) +@end example + +@c ----------------------- +@node slime-macroexpansion-minor-mode +@section slime-macroexpansion-minor-mode + +Within a slime macroexpansion buffer some extra commands are provided +(these commands are always available but are only bound to keys in a +macroexpansion buffer). + +@table @kbd +@kbditem{C-c C-m, slime-macroexpand-1-inplace} +Just like slime-macroexpand-1 but the original form is replaced with +the expansion. + +@c @anchor{slime-macroexpand-1-inplace} +@kbditem{g, slime-macroexpand-1-inplace} +The last macroexpansion is performed again, the current contents of +the macroexpansion buffer are replaced with the new expansion. + +@kbditem{q, slime-temp-buffer-quit} +Close the expansion buffer. + +@end table + +@c ----------------------- +@node Multiple connections +@section Multiple connections + +@SLIME{} is able to connect to multiple Lisp processes at the same +time. The @kbd{M-x slime} command, when invoked with a prefix +argument, will offer to create an additional Lisp process if one is +already running. This is often convenient, but it requires some +understanding to make sure that your @SLIME{} commands execute in the +Lisp that you expect them to. + +Some buffers are tied to specific Lisp processes. Each Lisp connection +has its own @acronym{REPL} buffer, and all expressions entered or +@SLIME{} commands invoked in that buffer are sent to the associated +connection. Other buffers created by @SLIME{} are similarly tied to +the connections they originate from, including @SLDB{} buffers, +apropos result listings, and so on. These buffers are the result of +some interaction with a Lisp process, so commands in them always go +back to that same process. + +Commands executed in other places, such as @code{slime-mode} source +buffers, always use the ``default'' connection. Usually this is the +most recently established connection, but this can be reassigned via +the ``connection list'' buffer: + +@table @kbd +@kbditem{C-c C-x c, slime-list-connections} +Pop up a buffer listing the established connections. + +@kbditem{C-c C-x t, slime-list-threads} +Pop up a buffer listing the current threads. + +@end table + +The buffer displayed by @code{slime-list-connections} gives a one-line +summary of each connection. The summary shows the connection's serial +number, the name of the Lisp implementation, and other details of the +Lisp process. The current ``default'' connection is indicated with an +asterisk. + +The commands available in the connection-list buffer are: + +@table @kbd +@kbditem{RET, slime-goto-connection} +Pop to the @acronym{REPL} buffer of the connection at point. + +@kbditem{d, slime-connection-list-make-default} +Make the connection at point the ``default'' connection. It will then +be used for commands in @code{slime-mode} source buffers. + +@kbditem{g, slime-update-connection-list} +Update the connection list in the buffer. + +@kbditem{q, slime-temp-buffer-quit} +Quit the connection list (kill buffer, restore window configuration). + +@kbditem{R, slime-restart-connection-at-point} +Restart the Lisp process for the connection at point. + +@cmditem{slime-connect} +Connect to a running Swank server. + +@cmditem{slime-disconnect} +Disconnect all connections. + +@cmditem{slime-abort-connection} +Abort the current attempt to connect. + +@end table + +@c ----------------------- +@node Typeout frames +@section Typeout frames + +A ``typeout frame'' is a special Emacs frame which is used instead of +the echo area (minibuffer) to display messages from @SLIME{} commands. +This is an optional feature. The advantage of a typeout frame over the +echo area is that it can hold more text, it can be scrolled, and its +contents don't disappear when you press a key. All potentially long +messages are sent to the typeout frame, such as argument lists, macro +expansions, and so on. + +@table @kbd +@cmditem{slime-ensure-typeout-frame} +Ensure that a typeout frame exists, creating one if necessary. +@end table + +If the typeout frame is closed then the echo area will be used again +as usual. + +To have a typeout frame created automatically at startup you can add +the @code{slime-connected-hook} to your @file{~/.emacs} file: + +@example +(add-hook 'slime-connected-hook 'slime-ensure-typeout-frame) +@end example + +@c ----------------------- +@node Customization +@chapter Customization + +@menu +* Emacs-side customization:: +* Lisp-side:: +@end menu + +@c ----------------------- +@node Emacs-side customization +@section Emacs-side + +The Emacs part of @SLIME{} can be configured with the Emacs +@code{customize} system, just use @kbd{M-x customize-group slime +RET}. Because the customize system is self-describing, we only cover a +few important or obscure configuration options here in the manual. + +@table @code + +@item slime-truncate-lines +The value to use for @code{truncate-lines} in line-by-line summary +buffers popped up by @SLIME{}. This is @code{t} by default, which +ensures that lines do not wrap in backtraces, apropos listings, and so +on. It can however cause information to spill off the screen. + +@anchor{slime-complete-symbol-function} +@vindex slime-complete-symbol-function +@item slime-complete-symbol-function +The function to use for completion of Lisp symbols. Three completion +styles are available. The default @code{slime-complete-symbol*} +performs completion ``in parallel'' over the hyphen-delimited +sub-words of a symbol name. +@footnote{This style of completion is modelled on @file{completer.el} +by Chris McConnell. That package is bundled with @acronym{ILISP}.} +Formally this means that ``@code{a-b-c}'' can complete to any symbol +matching the regular expression ``(a)code{^a.*-b.*-c.*}'' (where ``dot'' +matches anything but a hyphen). Examples give a more intuitive +feeling: +@itemize @bullet +@item +@code{m-v-b} completes to @code{multiple-value-bind}. +@item +@code{w-open} is ambiguous: it completes to either +@code{with-open-file} or @code{with-open-stream}. The symbol is +expanded to the longest common completion (@code{with-open-}) and the +point is placed at the first point of ambiguity, which in this case is +the end. +@item +@code{w--stream} completes to @code{with-open-stream}. +@end itemize +An alternative is @code{slime-simple-complete-symbol}, which +completes in the usual Emacs way. Finally, there is +@code{slime-fuzzy-complete-symbol}, which is quite different from both +of the above and tries to find best matches to an abbreviated symbol. +It also has its own key binding, defaulting to @kbd{C-c M-i}. +@xref{slime-fuzzy-complete-symbol}, for more information. + +@vindex slime-filename-translations +@item slime-filename-translations +This variable controls filename translation between Emacs and the Lisp +system. It is useful if you run Emacs and Lisp on separate machines +which don't share a common file system or if they share the filessytem +but have different layouts, as is the case with @acronym{SMB}-based +file sharing. + +@vindex slime-net-coding-system +@item slime-net-coding-system +If you want to transmit Unicode characters between Emacs and the Lisp +system, you should customize this variable. E.g., if you use SBCL, you +can set: +@example +(setq slime-net-coding-system 'utf-8-unix) +@end example +To actually display Unicode characters you also need appropriate fonts, +otherwise the characters will be rendered as hollow boxes. If you are +using Allegro CL and GNU Emacs, you can also use @code{emacs-mule-unix} +as coding system. GNU Emacs has often nicer fonts for the latter +encoding. + +@end table + +@menu +* Hooks:: +@end menu + +@c ----------------------- +@node Hooks +@subsection Hooks + +@table @code + +@vindex slime-mode-hook +@item slime-mode-hook +This hook is run each time a buffer enters @code{slime-mode}. It is +most useful for setting buffer-local configuration in your Lisp source +buffers. An example use is to enable @code{slime-autodoc-mode} +(@pxref{slime-autodoc-mode}). + +@vindex slime-connected-hook +@item slime-connected-hook +This hook is run when @SLIME{} establishes a connection to a Lisp +server. An example use is to create a Typeout frame (@xref{Typeout frames}.) + +@vindex sldb-hook +@item sldb-hook +This hook is run after @SLDB{} is invoked. The hook functions are +called from the @SLDB{} buffer after it is initialized. An example use +is to add @code{sldb-print-condition} to this hook, which makes all +conditions debugged with @SLDB{} be recorded in the @REPL{} buffer. + +@end table + +@c ----------------------- +@node Lisp-side +@section Lisp-side (Swank) + +The Lisp server side of @SLIME{} (known as ``Swank'') offers several +variables to configure. The initialization file @file{~/.swank.lisp} +is automatically evaluated at startup and can be used to set these +variables. + +@menu +* Communication style:: +* Other configurables:: +@end menu + +@c ----------------------- +@node Communication style +@subsection Communication style +@vindex SWANK:*COMMUNICATION-STYLE* + +The most important configurable is @code{SWANK:*COMMUNICATION-STYLE*}, +which specifies the mechanism by which Lisp reads and processes +protocol messages from Emacs. The choice of communication style has a +global influence on @SLIME{}'s operation. + +The available communication styles are: + +@table @code +@item NIL +This style simply loops reading input from the communication socket +and serves @SLIME{} protocol events as they arise. The simplicity +means that the Lisp cannot do any other processing while under +@SLIME{}'s control. + +@item :FD-HANDLER +This style uses the classical Unix-style ``@code{select()}-loop.'' +Swank registers the communication socket with an event-dispatching +framework (such as @code{SERVE-EVENT} in @acronym{CMUCL} and +@acronym{SBCL}) and receives a callback when data is available. In +this style requests from Emacs are only detected and processed when +Lisp enters the event-loop. This style is simple and predictable. + +@item :SIGIO +This style uses @dfn{signal-driven I/O} with a @code{SIGIO} signal +handler. Lisp receives requests from Emacs along with a signal, +causing it to interrupt whatever it is doing to serve the +request. This style has the advantage of responsiveness, since Emacs +can perform operations in Lisp even while it is busy doing other +things. It also allows Emacs to issue requests concurrently, e.g. to +send one long-running request (like compilation) and then interrupt +that with several short requests before it completes. The +disadvantages are that it may conflict with other uses of @code{SIGIO} +by Lisp code, and it may cause untold havoc by interrupting Lisp at an +awkward moment. + +@item :SPAWN +This style uses multiprocessing support in the Lisp system to execute +each request in a separate thread. This style has similar properties +to @code{:SIGIO}, but it does not use signals and all requests issued +by Emacs can be executed in parallel. + +@end table + +The default request handling style is chosen according to the +capabilities of your Lisp system. The general order of preference is +@code{:SPAWN}, then @code{:SIGIO}, then @code{:FD-HANDLER}, with +@code{NIL} as a last resort. You can check the default style by +calling @code{SWANK-BACKEND:PREFERRED-COMMUNICATION-STYLE}. You can +also override the default by setting +@code{SWANK:*COMMUNICATION-STYLE*} in your Swank init file. + +@c ----------------------- +@node Other configurables +@subsection Other configurables + +These Lisp variables can be configured via your @file{~/.swank.lisp} +file: + +@table @code + +@vindex SWANK:*CONFIGURE-EMACS-INDENTATION* +@item SWANK:*CONFIGURE-EMACS-INDENTATION* +This variable controls whether indentation styles for +@code{&body}-arguments in macros are discovered and sent to Emacs. It +is enabled by default. + +@vindex SWANK:*GLOBALLY-REDIRECT-IO* +@item SWANK:*GLOBALLY-REDIRECT-IO* +When true this causes the standard streams (@code{*standard-output*}, +etc) to be globally redirected to the @REPL{} in Emacs. When +@code{NIL} (the default) these streams are only temporarily redirected +to Emacs using dynamic bindings while handling requests. Note that +@code{*standard-input*} is currently never globally redirected into +Emacs, because it can interact badly with the Lisp's native @REPL{} by +having it try to read from the Emacs one. + +@vindex SWANK:*GLOBAL-DEBUGGER* +@item SWANK:*GLOBAL-DEBUGGER* +When true (the default) this causes @code{*DEBUGGER-HOOK*} to be +globally set to @code{SWANK:SWANK-DEBUGGER-HOOK} and thus for @SLIME{} +to handle all debugging in the Lisp image. This is for debugging +multithreaded and callback-driven applications. + +@vindex SWANK:*SLDB-PRINTER-BINDINGS* +@vindex SWANK:*MACROEXPAND-PRINTER-BINDINGS* +@vindex SWANK:*SWANK-PPRINT-BINDINGS* +@item SWANK:*SLDB-PRINTER-BINDINGS* +@itemx SWANK:*MACROEXPAND-PRINTER-BINDINGS* +@itemx SWANK:*SWANK-PPRINT-BINDINGS* +These variables can be used to customize the printer in various +situations. The values of the variables are association lists of +printer variable names with the corresponding value. E.g., to enable +the pretty printer for formatting backtraces in @SLDB{}, you can use: +@example +(push '(*print-pretty* . t) swank:*sldb-printer-bindings*). +@end example + +@vindex SWANK:*USE-DEDICATED-OUTPUT-STREAM* +@item SWANK:*USE-DEDICATED-OUTPUT-STREAM* +This variable controls whether to use an unsafe efficiency hack for +sending printed output from Lisp to Emacs. The default is @code{nil}, +don't use it, and is strongly recommended to keep. + +When @code{t}, a separate socket is established solely for Lisp to send +printed output to Emacs through, which is faster than sending the output +in protocol-messages to Emacs. However, as nothing can be guaranteed +about the timing between the dedicated output stream and the stream of +protocol messages, the output of a Lisp command can arrive before or +after the corresponding REPL results. Thus output and REPL results can +end up in the wrong order, or even interleaved, in the REPL buffer. +Using a dedicated output stream also makes it more difficult to +communicate to a Lisp running on a remote host via SSH +(@pxref{Connecting to a remote lisp}). + +@vindex SWANK:*DEDICATED-OUTPUT-STREAM-PORT* +@item SWANK:*DEDICATED-OUTPUT-STREAM-PORT* +When @code{*USE-DEDICATED-OUTPUT-STREAM*} is @code{t} the stream will +be opened on this port. The default value, @code{0}, means that the +stream will be opened on some random port. + +@vindex SWANK:*LOG-EVENTS* +@item SWANK:*LOG-EVENTS* +Setting this variable to @code{t} causes all protocol messages +exchanged with Emacs to be printed to @code{*TERMINAL-IO*}. This is +useful for low-level debugging and for observing how @SLIME{} works +``on the wire.'' The output of @code{*TERMINAL-IO*} can be found in +your Lisp system's own listener, usually in the buffer +@code{*inferior-lisp*}. + +@end table + +@c ----------------------- +@node Tips and Tricks +@chapter Tips and Tricks + +@menu +* Connecting to a remote lisp:: +* Global IO Redirection:: +* Auto-SLIME:: +@end menu + +@c ----------------------- +@node Connecting to a remote lisp +@section Connecting to a remote lisp + +One of the advantages of the way @SLIME{} is implemented is that we +can easily run the Emacs side (slime.el) on one machine and the lisp +backend (swank) on another. The basic idea is to start up lisp on the +remote machine, load swank and wait for incoming slime connections. On +the local machine we start up emacs and tell slime to connect to the +remote machine. The details are a bit messier but the underlying idea +is that simple. + +@menu +* Setting up the lisp image:: +* Setting up Emacs:: +* Setting up pathname translations:: +@end menu + +@c ----------------------- +@node Setting up the lisp image +@subsection Setting up the lisp image + + +When you want to load swank without going through the normal, Emacs +based, process just load the @file{swank-loader.lisp} file. Just +execute + +@example +(load "/path/to/swank-loader.lisp") +@end example + +inside a running lisp image@footnote{@SLIME{} also provides an +@acronym{ASDF} system definiton which does the same thing}. Now all we +need to do is startup our swank server. The first example assumes we're +using the default settings. + +@example +(swank:create-server) +@end example + +Since we're going to be tunneling our connection via +ssh@footnote{there is a way to connect without an ssh tunnel, but it +has the side-effect of giving the entire world access to your lisp +image, so we're not going to talk about it} and we'll only have one +port open we want to tell swank to not use an extra connection for +output (this is actually the default in current SLIME): + +@example +(setf swank:*use-dedicated-output-stream* nil) +@end example + +@c ----------------------- +If you need to do anything particular +(like be able to reconnect to swank after you're done), look into +@code{swank:create-server}'s other arguments. Some of these arguments +are +@table @code + +@item :PORT +Port number for the server to listen on (default: 4005). +@item :STYLE +See @xref{Communication style}. +@item :DONT-CLOSE +Boolean indicating if the server will continue to accept connections +after the first one (default: @code{NIL}). For ``long-running'' lisp processes +to which you want to be able to connect from time to time, +specify @code{:dont-close t} +@item :CODING-SYSTEM +String designating the encoding to be used to communicate between the +Emacs and Lisp. +@end table + +So the more complete example will be +@example +(swank:create-server :port 4005 :dont-close t :coding-system "utf-8-unix") +@end example +On the emacs side you will use something like +@example +(setq slime-net-coding-system 'utf-8-unix) +(slime-connect "127.0.0.1" 4005)) +@end example +to connect to this lisp image from the same machine. + + +@node Setting up Emacs +@subsection Setting up Emacs + +Now we need to create the tunnel between the local machine and the +remote machine. + +@example +ssh -L4005:127.0.0.1:4005 username@@remote.example.com +@end example + +That ssh invocation creates an ssh tunnel between the port 4005 on our +local machine and the port 4005 on the remote machine@footnote{By +default swank listens for incoming connections on port 4005, had we +passed a @code{:port} parameter to @code{swank:create-server} we'd be +using that port number instead}. + +Finally we can start @SLIME{}: + +@example +M-x slime-connect RET RET +@end example + +The @kbd{RET RET} sequence just means that we want to use the default +host (@code{127.0.0.1}) and the default port (@code{4005}). Even +though we're connecting to a remote machine the ssh tunnel fools Emacs +into thinking it's actually @code{127.0.0.1}. + +@c ----------------------- +@node Setting up pathname translations +@subsection Setting up pathname translations + +One of the main problems with running swank remotely is that Emacs +assumes the files can be found using normal filenames. if we want +things like @code{slime-compile-and-load-file} (@kbd{C-c C-k}) and +@code{slime-edit-definition} (@kbd{M-.}) to work correctly we need to +find a way to let our local Emacs refer to remote files. + +There are, mainly, two ways to do this. The first is to mount, using +NFS or similar, the remote machine's hard disk on the local machine's +file system in such a fashion that a filename like +(a)file{/opt/project/source.lisp} refers to the same file on both +machines. Unfortunetly NFS is usually slow, often buggy, and not +always feasable, fortunetely we have an ssh connection and Emacs' +@code{tramp-mode} can do the rest. + +What we do is teach Emacs how to take a filename on the remote machine +and translate it into something that tramp can understand and access +(and vice-versa). Assuming the remote machine's host name is +(a)code{remote.example.com}, @code{cl:machine-instance} returns +``remote'' and we login as the user ``user'' we can use @SLIME{}'s +built-in mechanism to setup the proper transaltions by simply doing: + +@example +(push (slime-create-filename-translator :machine-instance "remote.example.com" + :remote-host "remote" + :username "user") + slime-filename-translations) +@end example + +@c ----------------------- +@node Global IO Redirection +@section Globally redirecting all IO to the REPL + +By default @SLIME{} does not change @code{*standard-output*} and +friends outside of the @REPL{}. If you have any other threads which +call @code{format}, @code{write-string}, etc. that output will be seen +only in the @code{*inferior-lisp*} buffer or on the terminal, more +often than not this is inconvenient. So, if you want code such as this: + +@example +(run-in-new-thread + (lambda () + (write-line "In some random thread.~%" *standard-output*))) +@end example + +to send its output to @SLIME{}'s repl buffer, as opposed to +@code{*inferior-lisp*}, set @code{swank:*globally-redirect-io*} to T. + +Note that the value of this variable is only checked when swank +accepts the connection so you should set it via +(a)file{~/.swank.lisp}. Otherwise you will need to call +@code{swank::globally-redirect-io-to-connection} yourself, but you +shouldn't do that unless you know what you're doing. + +@c ----------------------- +@node Auto-SLIME +@section Connecting to SLIME automatically + +To make @SLIME{} connect to your lisp whenever you open a lisp file +just add this to your @file{.emacs}: + +@example +(add-hook 'slime-mode-hook + (lambda () + (unless (slime-connected-p) + (save-excursion (slime))))) +@end example + + +@c ----------------------- +@node Credits +@chapter Credits + +@emph{The soppy ending...} + +@unnumberedsec Hackers of the good hack + +@SLIME{} is an Extension of @acronym{SLIM} by Eric Marsden. At the +time of writing, the authors and code-contributors of @SLIME{} are: + +@include contributors.texi + +... not counting the bundled code from @file{hyperspec.el}, +@cite{CLOCC}, and the @cite{CMU AI Repository}. + +Many people on the @code{slime-devel} mailing list have made non-code +contributions to @SLIME{}. Life is hard though: you gotta send code to +get your name in the manual. @code{:-)} + +@unnumberedsec Thanks! + +We're indebted to the good people of @code{common-lisp.net} for their +hosting and help, and for rescuing us from ``Sourceforge hell.'' + +Implementors of the Lisps that we support have been a great help. We'd +like to thank the @acronym{CMUCL} maintainers for their helpful +answers, Craig Norvell and Kevin Layer at Franz providing Allegro CL +licenses for @SLIME{} development, and Peter Graves for his help to +get @SLIME{} running with @acronym{ABCL}. + +Most of all we're happy to be working with the Lisp implementors +who've joined in the @SLIME{} development: Dan Barlow and Christophe +Rhodes of @acronym{SBCL}, Gary Byers of OpenMCL, and Martin Simmons of +LispWorks. Thanks also to Alain Picard and Memetrics for funding +Martin's initial work on the LispWorks backend! + +@ignore +This index is currently ingored, because texinfo's built-in indexing +produces nicer results. -- Helmut Eller + +@node Index to Functions +@appendix Index to Functions + +These functions are all available (when relevant). To find the +keybinding (if there is one) refer to the function description. + +@c Note to editors: @fcnindex{...} lines commented out below are place holders +@c ---------------- +@c They have yet to be documented +@c Please feel free to add descriptions in the text where appropriate, add the +@c appropriate anchors and uncomment them. +@c +@c [jkc] + +@table @code +@fcnindex{common-lisp-hyperspec-format} +@fcnindex{sldb-abort} +@c @fcnindex{sldb-activate} +@c @fcnindex{sldb-add-face} +@c @fcnindex{sldb-backward-frame} +@c @fcnindex{sldb-beginning-of-backtrace} +@c @fcnindex{sldb-break} +@c @fcnindex{sldb-break-on-return} +@fcnindex{sldb-break-with-default-debugger} +@c @fcnindex{sldb-buffers} +@c @fcnindex{sldb-catch-tags} +@fcnindex{sldb-continue} +@c @fcnindex{sldb-debugged-continuations} +@c @fcnindex{sldb-default-action} +@c @fcnindex{sldb-default-action/mouse} +@c @fcnindex{sldb-delete-overlays} +@c @fcnindex{sldb-details-down} +@c @fcnindex{sldb-details-up} +@fcnindex{sldb-disassemble} +@c @fcnindex{sldb-dispatch-extras} +@c @fcnindex{sldb-down} +@c @fcnindex{sldb-end-of-backtrace} +@fcnindex{sldb-eval-in-frame} +@c @fcnindex{sldb-exit} +@c @fcnindex{sldb-fetch-all-frames} +@c @fcnindex{sldb-fetch-more-frames} +@c @fcnindex{sldb-find-buffer} +@c @fcnindex{sldb-format-reference-node} +@c @fcnindex{sldb-format-reference-source} +@c @fcnindex{sldb-forward-frame} +@c @fcnindex{sldb-frame-details-visible-p} +@c @fcnindex{sldb-frame-locals} +@c @fcnindex{sldb-frame-number-at-point} +@c @fcnindex{sldb-frame-region} +@c @fcnindex{sldb-get-buffer} +@c @fcnindex{sldb-get-default-buffer} +@c @fcnindex{sldb-goto-last-frame} +@c @fcnindex{sldb-help-summary} +@c @fcnindex{sldb-hide-frame-details} +@c @fcnindex{sldb-highlight-sexp} +@c @fcnindex{sldb-insert-condition} +@c @fcnindex{sldb-insert-frame} +@c @fcnindex{sldb-insert-frames} +@c @fcnindex{sldb-insert-locals} +@c @fcnindex{sldb-insert-references} +@c @fcnindex{sldb-insert-restarts} +@c @fcnindex{sldb-inspect-condition} +@fcnindex{sldb-inspect-in-frame} +@c @fcnindex{sldb-inspect-var} +@c @fcnindex{sldb-invoke-restart} +@c @fcnindex{sldb-level} +@c @fcnindex{sldb-list-catch-tags} +@c @fcnindex{sldb-list-locals} +@c @fcnindex{sldb-lookup-reference} +@c @fcnindex{sldb-maybe-recenter-region} +@c @fcnindex{sldb-mode-hook} +@c @fcnindex{sldb-next} +@c @fcnindex{sldb-out} +@fcnindex{sldb-pprint-eval-in-frame} +@c @fcnindex{sldb-previous-frame-number} +@c @fcnindex{sldb-print-condition} +@c @fcnindex{sldb-prune-initial-frames} +@fcnindex{sldb-quit} +@c @fcnindex{sldb-reference-properties} +@c @fcnindex{sldb-restart-at-point} +@fcnindex{sldb-restart-frame} +@fcnindex{sldb-return-from-frame} +@c @fcnindex{sldb-setup} +@c @fcnindex{sldb-show-frame-details} +@c @fcnindex{sldb-show-frame-source} +@fcnindex{sldb-show-source} +@fcnindex{sldb-step} +@c @fcnindex{sldb-sugar-move} +@fcnindex{sldb-toggle-details} +@c @fcnindex{sldb-up} +@c @fcnindex{sldb-var-number-at-point} +@c @fcnindex{sldb-xemacs-emulate-point-entered-hook} +@c @fcnindex{sldb-xemacs-post-command-hook} + + +@c @fcnindex{inferior-slime-closing-return} +@c @fcnindex{inferior-slime-indent-line} +@c @fcnindex{inferior-slime-mode} +@c @fcnindex{inferior-slime-return} +@fcnindex{slime-abort-connection} +@fcnindex{slime-apropos} +@fcnindex{slime-apropos-all} +@fcnindex{slime-apropos-package} +@c @fcnindex{slime-arglist} +@fcnindex{slime-autodoc-mode} +@c @fcnindex{slime-autodoc-start-timer} +@c @fcnindex{slime-background-activities-enabled-p} +@c @fcnindex{slime-background-message} +@c @fcnindex{slime-browse-classes} +@c @fcnindex{slime-browse-xrefs} +@fcnindex{slime-call-defun} +@fcnindex{slime-calls-who} +@c @fcnindex{slime-check-coding-system} +@fcnindex{slime-close-all-sexp} +@fcnindex{slime-close-parens-at-point} +@fcnindex{slime-compile-and-load-file} +@fcnindex{slime-compile-defun} +@fcnindex{slime-compile-file} +@fcnindex{slime-compile-region} +@fcnindex{slime-compiler-macroexpand} +@fcnindex{slime-compiler-macroexpand-1} +@c @fcnindex{slime-compiler-notes-default-action-or-show-details} +@c @fcnindex{slime-compiler-notes-default-action-or-show-details/mouse} +@c @fcnindex{slime-compiler-notes-quit} +@c @fcnindex{slime-compiler-notes-show-details} +@c @fcnindex{slime-complete-form} +@fcnindex{slime-complete-symbol} +@fcnindex{slime-connect} +@fcnindex{slime-connection-list-make-default} +@c @fcnindex{slime-connection-list-mode} +@c @fcnindex{slime-copy-presentation-at-point} +@fcnindex{slime-describe-function} +@fcnindex{slime-describe-symbol} +@fcnindex{slime-disassemble-symbol} +@fcnindex{slime-disconnect} +@c @fcnindex{slime-documentation} +@fcnindex{slime-edit-definition} +@fcnindex{slime-edit-definition-other-frame} +@fcnindex{slime-edit-definition-other-window} +@fcnindex{slime-edit-definition-with-etags} +@fcnindex{slime-edit-value} +@c @fcnindex{slime-edit-value-commit} +@c @fcnindex{slime-edit-value-mode} +@fcnindex{slime-ensure-typeout-frame} +@c @fcnindex{slime-eval-buffer} +@fcnindex{slime-eval-defun} +@fcnindex{slime-eval-last-expression} +@fcnindex{slime-eval-last-expression-display-output} +@c @fcnindex{slime-eval-print-last-expression} +@fcnindex{slime-eval-region} +@fcnindex{slime-fuzzy-abort} +@fcnindex{slime-fuzzy-complete-symbol} +@fcnindex{slime-fuzzy-completions-mode} +@c @fcnindex{slime-fuzzy-next} +@c @fcnindex{slime-fuzzy-prev} +@c @fcnindex{slime-fuzzy-select} +@c @fcnindex{slime-fuzzy-select/mouse} +@fcnindex{slime-goto-connection} +@fcnindex{slime-goto-xref} +@c @fcnindex{slime-handle-repl-shortcut} +@c @fcnindex{slime-highlight-notes} +@fcnindex{slime-hyperspec-lookup} +@c @fcnindex{slime-indent-and-complete-symbol} +@c @fcnindex{slime-init-keymaps} +@c @fcnindex{slime-insert-arglist} +@c @fcnindex{slime-insert-balanced-comments} +@fcnindex{slime-inspect} +@fcnindex{slime-inspector-copy-down} +@fcnindex{slime-inspector-describe} +@fcnindex{slime-inspector-next} +@c @fcnindex{slime-inspector-next-inspectable-object} +@fcnindex{slime-inspector-quit} +@c @fcnindex{slime-inspector-reinspect} +@fcnindex{slime-interactive-eval} +@fcnindex{slime-interrupt} +@fcnindex{slime-list-callees} +@fcnindex{slime-list-callers} +@c @fcnindex{slime-list-compiler-notes} +@fcnindex{slime-list-connections} +@c @fcnindex{slime-list-repl-shortcuts} +@fcnindex{slime-list-threads} +@fcnindex{slime-load-file} +@c @fcnindex{slime-load-system} +@fcnindex{slime-macroexpand-1} +@fcnindex{slime-macroexpand-1-inplace} +@fcnindex{slime-macroexpand-all} +@c @fcnindex{slime-make-default-connection} +@c @fcnindex{slime-make-typeout-frame} +@fcnindex{slime-mode} +@c @fcnindex{slime-next-line/not-add-newlines} +@c @fcnindex{slime-next-location} +@fcnindex{slime-next-note} +@fcnindex{slime-nop} +@c @fcnindex{slime-ping} +@fcnindex{slime-pop-find-definition-stack} +@fcnindex{slime-pprint-eval-last-expression} +@c @fcnindex{slime-presentation-menu} +@c @fcnindex{slime-pretty-lambdas} +@fcnindex{slime-previous-note} +@fcnindex{slime-profile-package} +@fcnindex{slime-profile-report} +@fcnindex{slime-profile-reset} +@fcnindex{slime-profiled-functions} +@fcnindex{slime-quit} +@c @fcnindex{slime-quit-connection-at-point} +@c @fcnindex{slime-quit-lisp} +@c @fcnindex{slime-re-evaluate-defvar} +@c @fcnindex{slime-recompile-bytecode} +@c @fcnindex{slime-register-lisp-implementation} +@fcnindex{slime-reindent-defun} +@c @fcnindex{slime-remove-balanced-comments} +@fcnindex{slime-remove-notes} +@c @fcnindex{slime-repl} +@fcnindex{slime-repl-beginning-of-defun} +@fcnindex{slime-repl-bol} +@fcnindex{slime-repl-clear-buffer} +@fcnindex{slime-repl-clear-output} +@fcnindex{slime-repl-closing-return} +@c @fcnindex{slime-repl-compile-and-load} +@c @fcnindex{slime-repl-compile-system} +@c @fcnindex{slime-repl-compile/force-system} +@c @fcnindex{slime-repl-defparameter} +@fcnindex{slime-repl-end-of-defun} +@c @fcnindex{slime-repl-eol} +@c @fcnindex{slime-repl-load-system} +@c @fcnindex{slime-repl-load/force-system} +@c @fcnindex{slime-repl-mode} +@fcnindex{slime-repl-newline-and-indent} +@fcnindex{slime-repl-next-input} +@fcnindex{slime-repl-next-matching-input} +@fcnindex{slime-repl-next-prompt} +@c @fcnindex{slime-repl-pop-directory} +@c @fcnindex{slime-repl-pop-packages} +@fcnindex{slime-repl-previous-input} +@fcnindex{slime-repl-previous-matching-input} +@fcnindex{slime-repl-previous-prompt} +@c @fcnindex{slime-repl-push-directory} +@c @fcnindex{slime-repl-push-package} +@c @fcnindex{slime-repl-read-break} +@c @fcnindex{slime-repl-read-mode} +@fcnindex{slime-repl-return} +@fcnindex{slime-repl-set-package} +@c @fcnindex{slime-repl-shortcut-help} +@c @fcnindex{slime-reset} +@c @fcnindex{slime-restart-connection-at-point} +@c @fcnindex{slime-restart-inferior-lisp} +@c @fcnindex{slime-restart-inferior-lisp-aux} +@fcnindex{slime-scratch} +@c @fcnindex{slime-select-lisp-implementation} +@fcnindex{slime-selector} +@c @fcnindex{slime-send-sigint} +@c @fcnindex{slime-set-default-directory} +@c @fcnindex{slime-set-package} +@c @fcnindex{slime-show-xref} +@fcnindex{slime-space} +@c @fcnindex{slime-start-and-load} +@fcnindex{slime-switch-to-output-buffer} +@fcnindex{slime-sync-package-and-default-directory} +@c @fcnindex{slime-temp-buffer-mode} +@fcnindex{slime-temp-buffer-quit} +@c @fcnindex{slime-thread-attach} +@c @fcnindex{slime-thread-debug} +@c @fcnindex{slime-thread-control-mode} +@c @fcnindex{slime-thread-kill} +@c @fcnindex{slime-thread-quit} +@fcnindex{slime-toggle-profile-fdefinition} +@fcnindex{slime-toggle-trace-fdefinition} +@fcnindex{slime-undefine-function} +@fcnindex{slime-unprofile-all} +@fcnindex{slime-untrace-all} +@fcnindex{slime-update-connection-list} +@c @fcnindex{slime-update-indentation} ??? +@fcnindex{slime-who-binds} +@fcnindex{slime-who-calls} +@fcnindex{slime-who-macroexpands} +@fcnindex{slime-who-references} +@fcnindex{slime-who-sets} +@fcnindex{slime-who-specializes} +@c @fcnindex{slime-xref-mode} +@c @fcnindex{slime-xref-quit} +@end table + +@end ignore + +@node Key Index, Command Index, Credits, top +@unnumbered Key (Character) Index +@printindex ky + +@node Command Index, Variable Index, Key Index, top +@unnumbered Command and Function Index +@printindex fn + +@node Variable Index, , Command Index, top +@unnumbered Variable Index +@printindex vr + +@bye Added: branches/trunk-reorg/thirdparty/slime/doc/texinfo-tabulate.awk =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/texinfo-tabulate.awk 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/texinfo-tabulate.awk 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,21 @@ +#!/usr/bin/env awk -f +# +# Format input lines into a multi-column texinfo table. +# Note: does not do texinfo-escaping of the input. + +# This code has been placed in the Public Domain. All warranties +# are disclaimed. + +BEGIN { + columns = 3; + printf("@multitable @columnfractions"); + for (i = 0; i < columns; i++) + printf(" %f", 1.0/columns); + print +} + +{ if (NR % columns == 1) printf("\n@item %s", $0); + else printf(" @tab %s", $0); } + +END { printf("\n@end multitable\n"); } + Added: branches/trunk-reorg/thirdparty/slime/hyperspec.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/hyperspec.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/hyperspec.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,1671 @@ +;;; hyperspec.el --- Browse documentation from the Common Lisp HyperSpec + +;; Copyright 1997 Naggum Software + +;; Author: Erik Naggum <erik(a)naggum.no> +;; Keywords: lisp + +;; This file is not part of GNU Emacs, but distributed under the same +;; conditions as GNU Emacs, and is useless without GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Kent Pitman and Xanalys Inc. have made the text of American National +;; Standard for Information Technology -- Programming Language -- Common +;; Lisp, ANSI X3.226-1994 available on the WWW, in the form of the Common +;; Lisp HyperSpec. This package makes it convenient to peruse this +;; documentation from within Emacs. + +;;; Code: + +(require 'cl) +(require 'browse-url) ;you need the Emacs 20 version +(require 'thingatpt) + +(defvar common-lisp-hyperspec-root + "http://www.lispworks.com/reference/HyperSpec/" + "The root of the Common Lisp HyperSpec URL. +If you copy the HyperSpec to your local system, set this variable to +something like \"file:/usr/local/doc/HyperSpec/\".") + +;;; Added variable for CLHS symbol table. See details below. +;;; +;;; 20011201 Edi Weitz + +(defvar common-lisp-hyperspec-symbol-table nil + "The HyperSpec symbol table file. +If you copy the HyperSpec to your local system, set this variable to +the location of the symbol table which is usually \"Map_Sym.txt\" +or \"Symbol-Table.text\".") + +(defvar common-lisp-hyperspec-history nil + "History of symbols looked up in the Common Lisp HyperSpec.") + +;;if only we had had packages or hash tables..., but let's fake it. + +(defvar common-lisp-hyperspec-symbols (make-vector 67 0)) + +(defun common-lisp-hyperspec-strip-cl-package (name) + (if (string-match "^\$[^:]*\$::?\$[^:]*\$$" name) + (let ((package-name (match-string 1 name)) + (symbol-name (match-string 2 name))) + (if (member (downcase package-name) + '("cl" "common-lisp")) + symbol-name + name)) + name)) + +(defun common-lisp-hyperspec (symbol-name) + "View the documentation on SYMBOL-NAME from the Common Lisp HyperSpec. +If SYMBOL-NAME has more than one definition, all of them are displayed with +your favorite browser in sequence. The browser should have a \"back\" +function to view the separate definitions. + +The Common Lisp HyperSpec is the full ANSI Standard Common Lisp, provided +by Kent Pitman and Xanalys Inc. By default, the Xanalys Web site is +visited to retrieve the information. Xanalys Inc. allows you to transfer +the entire Common Lisp HyperSpec to your own site under certain conditions. +Visit http://www.lispworks.com/reference/HyperSpec/ for more information. +If you copy the HyperSpec to another location, customize the variable +`common-lisp-hyperspec-root' to point to that location." + (interactive (list (let* ((symbol-at-point (thing-at-point 'symbol)) + (stripped-symbol + (and symbol-at-point + (substring-no-properties + (downcase + (common-lisp-hyperspec-strip-cl-package + symbol-at-point)))))) + (if (and stripped-symbol + (intern-soft stripped-symbol + common-lisp-hyperspec-symbols)) + stripped-symbol + (completing-read + "Look up symbol in Common Lisp HyperSpec: " + common-lisp-hyperspec-symbols #'boundp + t stripped-symbol + 'common-lisp-hyperspec-history))))) + (maplist (lambda (entry) + (browse-url (concat common-lisp-hyperspec-root "Body/" (car entry))) + (if (cdr entry) + (sleep-for 1.5))) + (let ((symbol (intern-soft + (common-lisp-hyperspec-strip-cl-package + (downcase symbol-name)) + common-lisp-hyperspec-symbols))) + (if (and symbol (boundp symbol)) + (symbol-value symbol) + (error "The symbol `%s' is not defined in Common Lisp" + symbol-name))))) + +;;; Added the following just to provide a common entry point according +;;; to the various 'hyperspec' implementations. +;;; +;;; 19990820 Marco Antoniotti + +(eval-when (load eval) + (defalias 'hyperspec-lookup 'common-lisp-hyperspec)) + + +;;; Added dynamic lookup of symbol in CLHS symbol table +;;; +;;; 20011202 Edi Weitz + +;;; Replaced symbol table for v 4.0 with the one for v 6.0 +;;; (which is now online at Xanalys' site) +;;; +;;; 20020213 Edi Weitz + +(if common-lisp-hyperspec-symbol-table + (let ((index-buffer (find-file-noselect common-lisp-hyperspec-symbol-table))) + (labels ((get-one-line () + (prog1 + (delete* ?\n (thing-at-point 'line)) + (forward-line)))) + (save-excursion + (set-buffer index-buffer) + (goto-char (point-min)) + (while (< (point) (point-max)) + (let* ((symbol (intern (downcase (get-one-line)) + common-lisp-hyperspec-symbols)) + (relative-url (get-one-line))) + (set symbol (list (subseq relative-url + (1+ (position ?\/ relative-url :from-end t)))))))))) + (mapcar (lambda (entry) + (let ((symbol (intern (car entry) common-lisp-hyperspec-symbols))) + (if (boundp symbol) + (push (cadr entry) (symbol-value symbol)) + (set symbol (cdr entry))))) + '(("&allow-other-keys" "03_da.htm") + ("&aux" "03_da.htm") + ("&body" "03_dd.htm") + ("&environment" "03_dd.htm") + ("&key" "03_da.htm") + ("&optional" "03_da.htm") + ("&rest" "03_da.htm") + ("&whole" "03_dd.htm") + ("*" "a_st.htm") + ("**" "v__stst_.htm") + ("***" "v__stst_.htm") + ("*break-on-signals*" "v_break_.htm") + ("*compile-file-pathname*" "v_cmp_fi.htm") + ("*compile-file-truename*" "v_cmp_fi.htm") + ("*compile-print*" "v_cmp_pr.htm") + ("*compile-verbose*" "v_cmp_pr.htm") + ("*debug-io*" "v_debug_.htm") + ("*debugger-hook*" "v_debugg.htm") + ("*default-pathname-defaults*" "v_defaul.htm") + ("*error-output*" "v_debug_.htm") + ("*features*" "v_featur.htm") + ("*gensym-counter*" "v_gensym.htm") + ("*load-pathname*" "v_ld_pns.htm") + ("*load-print*" "v_ld_prs.htm") + ("*load-truename*" "v_ld_pns.htm") + ("*load-verbose*" "v_ld_prs.htm") + ("*macroexpand-hook*" "v_mexp_h.htm") + ("*modules*" "v_module.htm") + ("*package*" "v_pkg.htm") + ("*print-array*" "v_pr_ar.htm") + ("*print-base*" "v_pr_bas.htm") + ("*print-case*" "v_pr_cas.htm") + ("*print-circle*" "v_pr_cir.htm") + ("*print-escape*" "v_pr_esc.htm") + ("*print-gensym*" "v_pr_gen.htm") + ("*print-length*" "v_pr_lev.htm") + ("*print-level*" "v_pr_lev.htm") + ("*print-lines*" "v_pr_lin.htm") + ("*print-miser-width*" "v_pr_mis.htm") + ("*print-pprint-dispatch*" "v_pr_ppr.htm") + ("*print-pretty*" "v_pr_pre.htm") + ("*print-radix*" "v_pr_bas.htm") + ("*print-readably*" "v_pr_rda.htm") + ("*print-right-margin*" "v_pr_rig.htm") + ("*query-io*" "v_debug_.htm") + ("*random-state*" "v_rnd_st.htm") + ("*read-base*" "v_rd_bas.htm") + ("*read-default-float-format*" "v_rd_def.htm") + ("*read-eval*" "v_rd_eva.htm") + ("*read-suppress*" "v_rd_sup.htm") + ("*readtable*" "v_rdtabl.htm") + ("*standard-input*" "v_debug_.htm") + ("*standard-output*" "v_debug_.htm") + ("*terminal-io*" "v_termin.htm") + ("*trace-output*" "v_debug_.htm") + ("+" "a_pl.htm") + ("++" "v_pl_plp.htm") + ("+++" "v_pl_plp.htm") + ("-" "a__.htm") + ("/" "a_sl.htm") + ("//" "v_sl_sls.htm") + ("///" "v_sl_sls.htm") + ("/=" "f_eq_sle.htm") + ("1+" "f_1pl_1_.htm") + ("1-" "f_1pl_1_.htm") + ("<" "f_eq_sle.htm") + ("<=" "f_eq_sle.htm") + ("=" "f_eq_sle.htm") + (">" "f_eq_sle.htm") + (">=" "f_eq_sle.htm") + ("abort" "a_abort.htm") + ("abs" "f_abs.htm") + ("acons" "f_acons.htm") + ("acos" "f_asin_.htm") + ("acosh" "f_sinh_.htm") + ("add-method" "f_add_me.htm") + ("adjoin" "f_adjoin.htm") + ("adjust-array" "f_adjust.htm") + ("adjustable-array-p" "f_adju_1.htm") + ("allocate-instance" "f_alloca.htm") + ("alpha-char-p" "f_alpha_.htm") + ("alphanumericp" "f_alphan.htm") + ("and" "a_and.htm") + ("append" "f_append.htm") + ("apply" "f_apply.htm") + ("apropos" "f_apropo.htm") + ("apropos-list" "f_apropo.htm") + ("aref" "f_aref.htm") + ("arithmetic-error" "e_arithm.htm") + ("arithmetic-error-operands" "f_arithm.htm") + ("arithmetic-error-operation" "f_arithm.htm") + ("array" "t_array.htm") + ("array-dimension" "f_ar_dim.htm") + ("array-dimension-limit" "v_ar_dim.htm") + ("array-dimensions" "f_ar_d_1.htm") + ("array-displacement" "f_ar_dis.htm") + ("array-element-type" "f_ar_ele.htm") + ("array-has-fill-pointer-p" "f_ar_has.htm") + ("array-in-bounds-p" "f_ar_in_.htm") + ("array-rank" "f_ar_ran.htm") + ("array-rank-limit" "v_ar_ran.htm") + ("array-row-major-index" "f_ar_row.htm") + ("array-total-size" "f_ar_tot.htm") + ("array-total-size-limit" "v_ar_tot.htm") + ("arrayp" "f_arrayp.htm") + ("ash" "f_ash.htm") + ("asin" "f_asin_.htm") + ("asinh" "f_sinh_.htm") + ("assert" "m_assert.htm") + ("assoc" "f_assocc.htm") + ("assoc-if" "f_assocc.htm") + ("assoc-if-not" "f_assocc.htm") + ("atan" "f_asin_.htm") + ("atanh" "f_sinh_.htm") + ("atom" "a_atom.htm") + ("base-char" "t_base_c.htm") + ("base-string" "t_base_s.htm") + ("bignum" "t_bignum.htm") + ("bit" "a_bit.htm") + ("bit-and" "f_bt_and.htm") + ("bit-andc1" "f_bt_and.htm") + ("bit-andc2" "f_bt_and.htm") + ("bit-eqv" "f_bt_and.htm") + ("bit-ior" "f_bt_and.htm") + ("bit-nand" "f_bt_and.htm") + ("bit-nor" "f_bt_and.htm") + ("bit-not" "f_bt_and.htm") + ("bit-orc1" "f_bt_and.htm") + ("bit-orc2" "f_bt_and.htm") + ("bit-vector" "t_bt_vec.htm") + ("bit-vector-p" "f_bt_vec.htm") + ("bit-xor" "f_bt_and.htm") + ("block" "s_block.htm") + ("boole" "f_boole.htm") + ("boole-1" "v_b_1_b.htm") + ("boole-2" "v_b_1_b.htm") + ("boole-and" "v_b_1_b.htm") + ("boole-andc1" "v_b_1_b.htm") + ("boole-andc2" "v_b_1_b.htm") + ("boole-c1" "v_b_1_b.htm") + ("boole-c2" "v_b_1_b.htm") + ("boole-clr" "v_b_1_b.htm") + ("boole-eqv" "v_b_1_b.htm") + ("boole-ior" "v_b_1_b.htm") + ("boole-nand" "v_b_1_b.htm") + ("boole-nor" "v_b_1_b.htm") + ("boole-orc1" "v_b_1_b.htm") + ("boole-orc2" "v_b_1_b.htm") + ("boole-set" "v_b_1_b.htm") + ("boole-xor" "v_b_1_b.htm") + ("boolean" "t_ban.htm") + ("both-case-p" "f_upper_.htm") + ("boundp" "f_boundp.htm") + ("break" "f_break.htm") + ("broadcast-stream" "t_broadc.htm") + ("broadcast-stream-streams" "f_broadc.htm") + ("built-in-class" "t_built_.htm") + ("butlast" "f_butlas.htm") + ("byte" "f_by_by.htm") + ("byte-position" "f_by_by.htm") + ("byte-size" "f_by_by.htm") + ("caaaar" "f_car_c.htm") + ("caaadr" "f_car_c.htm") + ("caaar" "f_car_c.htm") + ("caadar" "f_car_c.htm") + ("caaddr" "f_car_c.htm") + ("caadr" "f_car_c.htm") + ("caar" "f_car_c.htm") + ("cadaar" "f_car_c.htm") + ("cadadr" "f_car_c.htm") + ("cadar" "f_car_c.htm") + ("caddar" "f_car_c.htm") + ("cadddr" "f_car_c.htm") + ("caddr" "f_car_c.htm") + ("cadr" "f_car_c.htm") + ("call-arguments-limit" "v_call_a.htm") + ("call-method" "m_call_m.htm") + ("call-next-method" "f_call_n.htm") + ("car" "f_car_c.htm") + ("case" "m_case_.htm") + ("catch" "s_catch.htm") + ("ccase" "m_case_.htm") + ("cdaaar" "f_car_c.htm") + ("cdaadr" "f_car_c.htm") + ("cdaar" "f_car_c.htm") + ("cdadar" "f_car_c.htm") + ("cdaddr" "f_car_c.htm") + ("cdadr" "f_car_c.htm") + ("cdar" "f_car_c.htm") + ("cddaar" "f_car_c.htm") + ("cddadr" "f_car_c.htm") + ("cddar" "f_car_c.htm") + ("cdddar" "f_car_c.htm") + ("cddddr" "f_car_c.htm") + ("cdddr" "f_car_c.htm") + ("cddr" "f_car_c.htm") + ("cdr" "f_car_c.htm") + ("ceiling" "f_floorc.htm") + ("cell-error" "e_cell_e.htm") + ("cell-error-name" "f_cell_e.htm") + ("cerror" "f_cerror.htm") + ("change-class" "f_chg_cl.htm") + ("char" "f_char_.htm") + ("char-code" "f_char_c.htm") + ("char-code-limit" "v_char_c.htm") + ("char-downcase" "f_char_u.htm") + ("char-equal" "f_chareq.htm") + ("char-greaterp" "f_chareq.htm") + ("char-int" "f_char_i.htm") + ("char-lessp" "f_chareq.htm") + ("char-name" "f_char_n.htm") + ("char-not-equal" "f_chareq.htm") + ("char-not-greaterp" "f_chareq.htm") + ("char-not-lessp" "f_chareq.htm") + ("char-upcase" "f_char_u.htm") + ("char/=" "f_chareq.htm") + ("char<" "f_chareq.htm") + ("char<=" "f_chareq.htm") + ("char=" "f_chareq.htm") + ("char>" "f_chareq.htm") + ("char>=" "f_chareq.htm") + ("character" "a_ch.htm") + ("characterp" "f_chp.htm") + ("check-type" "m_check_.htm") + ("cis" "f_cis.htm") + ("class" "t_class.htm") + ("class-name" "f_class_.htm") + ("class-of" "f_clas_1.htm") + ("clear-input" "f_clear_.htm") + ("clear-output" "f_finish.htm") + ("close" "f_close.htm") + ("clrhash" "f_clrhas.htm") + ("code-char" "f_code_c.htm") + ("coerce" "f_coerce.htm") + ("compilation-speed" "d_optimi.htm") + ("compile" "f_cmp.htm") + ("compile-file" "f_cmp_fi.htm") + ("compile-file-pathname" "f_cmp__1.htm") + ("compiled-function" "t_cmpd_f.htm") + ("compiled-function-p" "f_cmpd_f.htm") + ("compiler-macro" "f_docume.htm") + ("compiler-macro-function" "f_cmp_ma.htm") + ("complement" "f_comple.htm") + ("complex" "a_comple.htm") + ("complexp" "f_comp_3.htm") + ("compute-applicable-methods" "f_comput.htm") + ("compute-restarts" "f_comp_1.htm") + ("concatenate" "f_concat.htm") + ("concatenated-stream" "t_concat.htm") + ("concatenated-stream-streams" "f_conc_1.htm") + ("cond" "m_cond.htm") + ("condition" "e_cnd.htm") + ("conjugate" "f_conjug.htm") + ("cons" "a_cons.htm") + ("consp" "f_consp.htm") + ("constantly" "f_cons_1.htm") + ("constantp" "f_consta.htm") + ("continue" "a_contin.htm") + ("control-error" "e_contro.htm") + ("copy-alist" "f_cp_ali.htm") + ("copy-list" "f_cp_lis.htm") + ("copy-pprint-dispatch" "f_cp_ppr.htm") + ("copy-readtable" "f_cp_rdt.htm") + ("copy-seq" "f_cp_seq.htm") + ("copy-structure" "f_cp_stu.htm") + ("copy-symbol" "f_cp_sym.htm") + ("copy-tree" "f_cp_tre.htm") + ("cos" "f_sin_c.htm") + ("cosh" "f_sinh_.htm") + ("count" "f_countc.htm") + ("count-if" "f_countc.htm") + ("count-if-not" "f_countc.htm") + ("ctypecase" "m_tpcase.htm") + ("debug" "d_optimi.htm") + ("decf" "m_incf_.htm") + ("declaim" "m_declai.htm") + ("declaration" "d_declar.htm") + ("declare" "s_declar.htm") + ("decode-float" "f_dec_fl.htm") + ("decode-universal-time" "f_dec_un.htm") + ("defclass" "m_defcla.htm") + ("defconstant" "m_defcon.htm") + ("defgeneric" "m_defgen.htm") + ("define-compiler-macro" "m_define.htm") + ("define-condition" "m_defi_5.htm") + ("define-method-combination" "m_defi_4.htm") + ("define-modify-macro" "m_defi_2.htm") + ("define-setf-expander" "m_defi_3.htm") + ("define-symbol-macro" "m_defi_1.htm") + ("defmacro" "m_defmac.htm") + ("defmethod" "m_defmet.htm") + ("defpackage" "m_defpkg.htm") + ("defparameter" "m_defpar.htm") + ("defsetf" "m_defset.htm") + ("defstruct" "m_defstr.htm") + ("deftype" "m_deftp.htm") + ("defun" "m_defun.htm") + ("defvar" "m_defpar.htm") + ("delete" "f_rm_rm.htm") + ("delete-duplicates" "f_rm_dup.htm") + ("delete-file" "f_del_fi.htm") + ("delete-if" "f_rm_rm.htm") + ("delete-if-not" "f_rm_rm.htm") + ("delete-package" "f_del_pk.htm") + ("denominator" "f_numera.htm") + ("deposit-field" "f_deposi.htm") + ("describe" "f_descri.htm") + ("describe-object" "f_desc_1.htm") + ("destructuring-bind" "m_destru.htm") + ("digit-char" "f_digit_.htm") + ("digit-char-p" "f_digi_1.htm") + ("directory" "f_dir.htm") + ("directory-namestring" "f_namest.htm") + ("disassemble" "f_disass.htm") + ("division-by-zero" "e_divisi.htm") + ("do" "m_do_do.htm") + ("do*" "m_do_do.htm") + ("do-all-symbols" "m_do_sym.htm") + ("do-external-symbols" "m_do_sym.htm") + ("do-symbols" "m_do_sym.htm") + ("documentation" "f_docume.htm") + ("dolist" "m_dolist.htm") + ("dotimes" "m_dotime.htm") + ("double-float" "t_short_.htm") + ("double-float-epsilon" "v_short_.htm") + ("double-float-negative-epsilon" "v_short_.htm") + ("dpb" "f_dpb.htm") + ("dribble" "f_dribbl.htm") + ("dynamic-extent" "d_dynami.htm") + ("ecase" "m_case_.htm") + ("echo-stream" "t_echo_s.htm") + ("echo-stream-input-stream" "f_echo_s.htm") + ("echo-stream-output-stream" "f_echo_s.htm") + ("ed" "f_ed.htm") + ("eighth" "f_firstc.htm") + ("elt" "f_elt.htm") + ("encode-universal-time" "f_encode.htm") + ("end-of-file" "e_end_of.htm") + ("endp" "f_endp.htm") + ("enough-namestring" "f_namest.htm") + ("ensure-directories-exist" "f_ensu_1.htm") + ("ensure-generic-function" "f_ensure.htm") + ("eq" "f_eq.htm") + ("eql" "a_eql.htm") + ("equal" "f_equal.htm") + ("equalp" "f_equalp.htm") + ("error" "a_error.htm") + ("etypecase" "m_tpcase.htm") + ("eval" "f_eval.htm") + ("eval-when" "s_eval_w.htm") + ("evenp" "f_evenpc.htm") + ("every" "f_everyc.htm") + ("exp" "f_exp_e.htm") + ("export" "f_export.htm") + ("expt" "f_exp_e.htm") + ("extended-char" "t_extend.htm") + ("fboundp" "f_fbound.htm") + ("fceiling" "f_floorc.htm") + ("fdefinition" "f_fdefin.htm") + ("ffloor" "f_floorc.htm") + ("fifth" "f_firstc.htm") + ("file-author" "f_file_a.htm") + ("file-error" "e_file_e.htm") + ("file-error-pathname" "f_file_e.htm") + ("file-length" "f_file_l.htm") + ("file-namestring" "f_namest.htm") + ("file-position" "f_file_p.htm") + ("file-stream" "t_file_s.htm") + ("file-string-length" "f_file_s.htm") + ("file-write-date" "f_file_w.htm") + ("fill" "f_fill.htm") + ("fill-pointer" "f_fill_p.htm") + ("find" "f_find_.htm") + ("find-all-symbols" "f_find_a.htm") + ("find-class" "f_find_c.htm") + ("find-if" "f_find_.htm") + ("find-if-not" "f_find_.htm") + ("find-method" "f_find_m.htm") + ("find-package" "f_find_p.htm") + ("find-restart" "f_find_r.htm") + ("find-symbol" "f_find_s.htm") + ("finish-output" "f_finish.htm") + ("first" "f_firstc.htm") + ("fixnum" "t_fixnum.htm") + ("flet" "s_flet_.htm") + ("float" "a_float.htm") + ("float-digits" "f_dec_fl.htm") + ("float-precision" "f_dec_fl.htm") + ("float-radix" "f_dec_fl.htm") + ("float-sign" "f_dec_fl.htm") + ("floating-point-inexact" "e_floa_1.htm") + ("floating-point-invalid-operation" "e_floati.htm") + ("floating-point-overflow" "e_floa_2.htm") + ("floating-point-underflow" "e_floa_3.htm") + ("floatp" "f_floatp.htm") + ("floor" "f_floorc.htm") + ("fmakunbound" "f_fmakun.htm") + ("force-output" "f_finish.htm") + ("format" "f_format.htm") + ("formatter" "m_format.htm") + ("fourth" "f_firstc.htm") + ("fresh-line" "f_terpri.htm") + ("fround" "f_floorc.htm") + ("ftruncate" "f_floorc.htm") + ("ftype" "d_ftype.htm") + ("funcall" "f_funcal.htm") + ("function" "a_fn.htm") + ("function-keywords" "f_fn_kwd.htm") + ("function-lambda-expression" "f_fn_lam.htm") + ("functionp" "f_fnp.htm") + ("gcd" "f_gcd.htm") + ("generic-function" "t_generi.htm") + ("gensym" "f_gensym.htm") + ("gentemp" "f_gentem.htm") + ("get" "f_get.htm") + ("get-decoded-time" "f_get_un.htm") + ("get-dispatch-macro-character" "f_set__1.htm") + ("get-internal-real-time" "f_get_in.htm") + ("get-internal-run-time" "f_get__1.htm") + ("get-macro-character" "f_set_ma.htm") + ("get-output-stream-string" "f_get_ou.htm") + ("get-properties" "f_get_pr.htm") + ("get-setf-expansion" "f_get_se.htm") + ("get-universal-time" "f_get_un.htm") + ("getf" "f_getf.htm") + ("gethash" "f_gethas.htm") + ("go" "s_go.htm") + ("graphic-char-p" "f_graphi.htm") + ("handler-bind" "m_handle.htm") + ("handler-case" "m_hand_1.htm") + ("hash-table" "t_hash_t.htm") + ("hash-table-count" "f_hash_1.htm") + ("hash-table-p" "f_hash_t.htm") + ("hash-table-rehash-size" "f_hash_2.htm") + ("hash-table-rehash-threshold" "f_hash_3.htm") + ("hash-table-size" "f_hash_4.htm") + ("hash-table-test" "f_hash_5.htm") + ("host-namestring" "f_namest.htm") + ("identity" "f_identi.htm") + ("if" "s_if.htm") + ("ignorable" "d_ignore.htm") + ("ignore" "d_ignore.htm") + ("ignore-errors" "m_ignore.htm") + ("imagpart" "f_realpa.htm") + ("import" "f_import.htm") + ("in-package" "m_in_pkg.htm") + ("incf" "m_incf_.htm") + ("initialize-instance" "f_init_i.htm") + ("inline" "d_inline.htm") + ("input-stream-p" "f_in_stm.htm") + ("inspect" "f_inspec.htm") + ("integer" "t_intege.htm") + ("integer-decode-float" "f_dec_fl.htm") + ("integer-length" "f_intege.htm") + ("integerp" "f_inte_1.htm") + ("interactive-stream-p" "f_intera.htm") + ("intern" "f_intern.htm") + ("internal-time-units-per-second" "v_intern.htm") + ("intersection" "f_isec_.htm") + ("invalid-method-error" "f_invali.htm") + ("invoke-debugger" "f_invoke.htm") + ("invoke-restart" "f_invo_1.htm") + ("invoke-restart-interactively" "f_invo_2.htm") + ("isqrt" "f_sqrt_.htm") + ("keyword" "t_kwd.htm") + ("keywordp" "f_kwdp.htm") + ("labels" "s_flet_.htm") + ("lambda" "a_lambda.htm") + ("lambda-list-keywords" "v_lambda.htm") + ("lambda-parameters-limit" "v_lamb_1.htm") + ("last" "f_last.htm") + ("lcm" "f_lcm.htm") + ("ldb" "f_ldb.htm") + ("ldb-test" "f_ldb_te.htm") + ("ldiff" "f_ldiffc.htm") + ("least-negative-double-float" "v_most_1.htm") + ("least-negative-long-float" "v_most_1.htm") + ("least-negative-normalized-double-float" "v_most_1.htm") + ("least-negative-normalized-long-float" "v_most_1.htm") + ("least-negative-normalized-short-float" "v_most_1.htm") + ("least-negative-normalized-single-float" "v_most_1.htm") + ("least-negative-short-float" "v_most_1.htm") + ("least-negative-single-float" "v_most_1.htm") + ("least-positive-double-float" "v_most_1.htm") + ("least-positive-long-float" "v_most_1.htm") + ("least-positive-normalized-double-float" "v_most_1.htm") + ("least-positive-normalized-long-float" "v_most_1.htm") + ("least-positive-normalized-short-float" "v_most_1.htm") + ("least-positive-normalized-single-float" "v_most_1.htm") + ("least-positive-short-float" "v_most_1.htm") + ("least-positive-single-float" "v_most_1.htm") + ("length" "f_length.htm") + ("let" "s_let_l.htm") + ("let*" "s_let_l.htm") + ("lisp-implementation-type" "f_lisp_i.htm") + ("lisp-implementation-version" "f_lisp_i.htm") + ("list" "a_list.htm") + ("list*" "f_list_.htm") + ("list-all-packages" "f_list_a.htm") + ("list-length" "f_list_l.htm") + ("listen" "f_listen.htm") + ("listp" "f_listp.htm") + ("load" "f_load.htm") + ("load-logical-pathname-translations" "f_ld_log.htm") + ("load-time-value" "s_ld_tim.htm") + ("locally" "s_locall.htm") + ("log" "f_log.htm") + ("logand" "f_logand.htm") + ("logandc1" "f_logand.htm") + ("logandc2" "f_logand.htm") + ("logbitp" "f_logbtp.htm") + ("logcount" "f_logcou.htm") + ("logeqv" "f_logand.htm") + ("logical-pathname" "a_logica.htm") + ("logical-pathname-translations" "f_logica.htm") + ("logior" "f_logand.htm") + ("lognand" "f_logand.htm") + ("lognor" "f_logand.htm") + ("lognot" "f_logand.htm") + ("logorc1" "f_logand.htm") + ("logorc2" "f_logand.htm") + ("logtest" "f_logtes.htm") + ("logxor" "f_logand.htm") + ("long-float" "t_short_.htm") + ("long-float-epsilon" "v_short_.htm") + ("long-float-negative-epsilon" "v_short_.htm") + ("long-site-name" "f_short_.htm") + ("loop" "m_loop.htm") + ("loop-finish" "m_loop_f.htm") + ("lower-case-p" "f_upper_.htm") + ("machine-instance" "f_mach_i.htm") + ("machine-type" "f_mach_t.htm") + ("machine-version" "f_mach_v.htm") + ("macro-function" "f_macro_.htm") + ("macroexpand" "f_mexp_.htm") + ("macroexpand-1" "f_mexp_.htm") + ("macrolet" "s_flet_.htm") + ("make-array" "f_mk_ar.htm") + ("make-broadcast-stream" "f_mk_bro.htm") + ("make-concatenated-stream" "f_mk_con.htm") + ("make-condition" "f_mk_cnd.htm") + ("make-dispatch-macro-character" "f_mk_dis.htm") + ("make-echo-stream" "f_mk_ech.htm") + ("make-hash-table" "f_mk_has.htm") + ("make-instance" "f_mk_ins.htm") + ("make-instances-obsolete" "f_mk_i_1.htm") + ("make-list" "f_mk_lis.htm") + ("make-load-form" "f_mk_ld_.htm") + ("make-load-form-saving-slots" "f_mk_l_1.htm") + ("make-method" "m_call_m.htm") + ("make-package" "f_mk_pkg.htm") + ("make-pathname" "f_mk_pn.htm") + ("make-random-state" "f_mk_rnd.htm") + ("make-sequence" "f_mk_seq.htm") + ("make-string" "f_mk_stg.htm") + ("make-string-input-stream" "f_mk_s_1.htm") + ("make-string-output-stream" "f_mk_s_2.htm") + ("make-symbol" "f_mk_sym.htm") + ("make-synonym-stream" "f_mk_syn.htm") + ("make-two-way-stream" "f_mk_two.htm") + ("makunbound" "f_makunb.htm") + ("map" "f_map.htm") + ("map-into" "f_map_in.htm") + ("mapc" "f_mapc_.htm") + ("mapcan" "f_mapc_.htm") + ("mapcar" "f_mapc_.htm") + ("mapcon" "f_mapc_.htm") + ("maphash" "f_maphas.htm") + ("mapl" "f_mapc_.htm") + ("maplist" "f_mapc_.htm") + ("mask-field" "f_mask_f.htm") + ("max" "f_max_m.htm") + ("member" "a_member.htm") + ("member-if" "f_mem_m.htm") + ("member-if-not" "f_mem_m.htm") + ("merge" "f_merge.htm") + ("merge-pathnames" "f_merge_.htm") + ("method" "t_method.htm") + ("method-combination" "a_method.htm") + ("method-combination-error" "f_meth_1.htm") + ("method-qualifiers" "f_method.htm") + ("min" "f_max_m.htm") + ("minusp" "f_minusp.htm") + ("mismatch" "f_mismat.htm") + ("mod" "a_mod.htm") + ("most-negative-double-float" "v_most_1.htm") + ("most-negative-fixnum" "v_most_p.htm") + ("most-negative-long-float" "v_most_1.htm") + ("most-negative-short-float" "v_most_1.htm") + ("most-negative-single-float" "v_most_1.htm") + ("most-positive-double-float" "v_most_1.htm") + ("most-positive-fixnum" "v_most_p.htm") + ("most-positive-long-float" "v_most_1.htm") + ("most-positive-short-float" "v_most_1.htm") + ("most-positive-single-float" "v_most_1.htm") + ("muffle-warning" "a_muffle.htm") + ("multiple-value-bind" "m_multip.htm") + ("multiple-value-call" "s_multip.htm") + ("multiple-value-list" "m_mult_1.htm") + ("multiple-value-prog1" "s_mult_1.htm") + ("multiple-value-setq" "m_mult_2.htm") + ("multiple-values-limit" "v_multip.htm") + ("name-char" "f_name_c.htm") + ("namestring" "f_namest.htm") + ("nbutlast" "f_butlas.htm") + ("nconc" "f_nconc.htm") + ("next-method-p" "f_next_m.htm") + ("nil" "a_nil.htm") + ("nintersection" "f_isec_.htm") + ("ninth" "f_firstc.htm") + ("no-applicable-method" "f_no_app.htm") + ("no-next-method" "f_no_nex.htm") + ("not" "a_not.htm") + ("notany" "f_everyc.htm") + ("notevery" "f_everyc.htm") + ("notinline" "d_inline.htm") + ("nreconc" "f_revapp.htm") + ("nreverse" "f_revers.htm") + ("nset-difference" "f_set_di.htm") + ("nset-exclusive-or" "f_set_ex.htm") + ("nstring-capitalize" "f_stg_up.htm") + ("nstring-downcase" "f_stg_up.htm") + ("nstring-upcase" "f_stg_up.htm") + ("nsublis" "f_sublis.htm") + ("nsubst" "f_substc.htm") + ("nsubst-if" "f_substc.htm") + ("nsubst-if-not" "f_substc.htm") + ("nsubstitute" "f_sbs_s.htm") + ("nsubstitute-if" "f_sbs_s.htm") + ("nsubstitute-if-not" "f_sbs_s.htm") + ("nth" "f_nth.htm") + ("nth-value" "m_nth_va.htm") + ("nthcdr" "f_nthcdr.htm") + ("null" "a_null.htm") + ("number" "t_number.htm") + ("numberp" "f_nump.htm") + ("numerator" "f_numera.htm") + ("nunion" "f_unionc.htm") + ("oddp" "f_evenpc.htm") + ("open" "f_open.htm") + ("open-stream-p" "f_open_s.htm") + ("optimize" "d_optimi.htm") + ("or" "a_or.htm") + ("otherwise" "m_case_.htm") + ("output-stream-p" "f_in_stm.htm") + ("package" "t_pkg.htm") + ("package-error" "e_pkg_er.htm") + ("package-error-package" "f_pkg_er.htm") + ("package-name" "f_pkg_na.htm") + ("package-nicknames" "f_pkg_ni.htm") + ("package-shadowing-symbols" "f_pkg_sh.htm") + ("package-use-list" "f_pkg_us.htm") + ("package-used-by-list" "f_pkg__1.htm") + ("packagep" "f_pkgp.htm") + ("pairlis" "f_pairli.htm") + ("parse-error" "e_parse_.htm") + ("parse-integer" "f_parse_.htm") + ("parse-namestring" "f_pars_1.htm") + ("pathname" "a_pn.htm") + ("pathname-device" "f_pn_hos.htm") + ("pathname-directory" "f_pn_hos.htm") + ("pathname-host" "f_pn_hos.htm") + ("pathname-match-p" "f_pn_mat.htm") + ("pathname-name" "f_pn_hos.htm") + ("pathname-type" "f_pn_hos.htm") + ("pathname-version" "f_pn_hos.htm") + ("pathnamep" "f_pnp.htm") + ("peek-char" "f_peek_c.htm") + ("phase" "f_phase.htm") + ("pi" "v_pi.htm") + ("plusp" "f_minusp.htm") + ("pop" "m_pop.htm") + ("position" "f_pos_p.htm") + ("position-if" "f_pos_p.htm") + ("position-if-not" "f_pos_p.htm") + ("pprint" "f_wr_pr.htm") + ("pprint-dispatch" "f_ppr_di.htm") + ("pprint-exit-if-list-exhausted" "m_ppr_ex.htm") + ("pprint-fill" "f_ppr_fi.htm") + ("pprint-indent" "f_ppr_in.htm") + ("pprint-linear" "f_ppr_fi.htm") + ("pprint-logical-block" "m_ppr_lo.htm") + ("pprint-newline" "f_ppr_nl.htm") + ("pprint-pop" "m_ppr_po.htm") + ("pprint-tab" "f_ppr_ta.htm") + ("pprint-tabular" "f_ppr_fi.htm") + ("prin1" "f_wr_pr.htm") + ("prin1-to-string" "f_wr_to_.htm") + ("princ" "f_wr_pr.htm") + ("princ-to-string" "f_wr_to_.htm") + ("print" "f_wr_pr.htm") + ("print-not-readable" "e_pr_not.htm") + ("print-not-readable-object" "f_pr_not.htm") + ("print-object" "f_pr_obj.htm") + ("print-unreadable-object" "m_pr_unr.htm") + ("probe-file" "f_probe_.htm") + ("proclaim" "f_procla.htm") + ("prog" "m_prog_.htm") + ("prog*" "m_prog_.htm") + ("prog1" "m_prog1c.htm") + ("prog2" "m_prog1c.htm") + ("progn" "s_progn.htm") + ("program-error" "e_progra.htm") + ("progv" "s_progv.htm") + ("provide" "f_provid.htm") + ("psetf" "m_setf_.htm") + ("psetq" "m_psetq.htm") + ("push" "m_push.htm") + ("pushnew" "m_pshnew.htm") + ("quote" "s_quote.htm") + ("random" "f_random.htm") + ("random-state" "t_rnd_st.htm") + ("random-state-p" "f_rnd_st.htm") + ("rassoc" "f_rassoc.htm") + ("rassoc-if" "f_rassoc.htm") + ("rassoc-if-not" "f_rassoc.htm") + ("ratio" "t_ratio.htm") + ("rational" "a_ration.htm") + ("rationalize" "f_ration.htm") + ("rationalp" "f_rati_1.htm") + ("read" "f_rd_rd.htm") + ("read-byte" "f_rd_by.htm") + ("read-char" "f_rd_cha.htm") + ("read-char-no-hang" "f_rd_c_1.htm") + ("read-delimited-list" "f_rd_del.htm") + ("read-from-string" "f_rd_fro.htm") + ("read-line" "f_rd_lin.htm") + ("read-preserving-whitespace" "f_rd_rd.htm") + ("read-sequence" "f_rd_seq.htm") + ("reader-error" "e_rder_e.htm") + ("readtable" "t_rdtabl.htm") + ("readtable-case" "f_rdtabl.htm") + ("readtablep" "f_rdta_1.htm") + ("real" "t_real.htm") + ("realp" "f_realp.htm") + ("realpart" "f_realpa.htm") + ("reduce" "f_reduce.htm") + ("reinitialize-instance" "f_reinit.htm") + ("rem" "f_mod_r.htm") + ("remf" "m_remf.htm") + ("remhash" "f_remhas.htm") + ("remove" "f_rm_rm.htm") + ("remove-duplicates" "f_rm_dup.htm") + ("remove-if" "f_rm_rm.htm") + ("remove-if-not" "f_rm_rm.htm") + ("remove-method" "f_rm_met.htm") + ("remprop" "f_rempro.htm") + ("rename-file" "f_rn_fil.htm") + ("rename-package" "f_rn_pkg.htm") + ("replace" "f_replac.htm") + ("require" "f_provid.htm") + ("rest" "f_rest.htm") + ("restart" "t_rst.htm") + ("restart-bind" "m_rst_bi.htm") + ("restart-case" "m_rst_ca.htm") + ("restart-name" "f_rst_na.htm") + ("return" "m_return.htm") + ("return-from" "s_ret_fr.htm") + ("revappend" "f_revapp.htm") + ("reverse" "f_revers.htm") + ("room" "f_room.htm") + ("rotatef" "m_rotate.htm") + ("round" "f_floorc.htm") + ("row-major-aref" "f_row_ma.htm") + ("rplaca" "f_rplaca.htm") + ("rplacd" "f_rplaca.htm") + ("safety" "d_optimi.htm") + ("satisfies" "t_satisf.htm") + ("sbit" "f_bt_sb.htm") + ("scale-float" "f_dec_fl.htm") + ("schar" "f_char_.htm") + ("search" "f_search.htm") + ("second" "f_firstc.htm") + ("sequence" "t_seq.htm") + ("serious-condition" "e_seriou.htm") + ("set" "f_set.htm") + ("set-difference" "f_set_di.htm") + ("set-dispatch-macro-character" "f_set__1.htm") + ("set-exclusive-or" "f_set_ex.htm") + ("set-macro-character" "f_set_ma.htm") + ("set-pprint-dispatch" "f_set_pp.htm") + ("set-syntax-from-char" "f_set_sy.htm") + ("setf" "a_setf.htm") + ("setq" "s_setq.htm") + ("seventh" "f_firstc.htm") + ("shadow" "f_shadow.htm") + ("shadowing-import" "f_shdw_i.htm") + ("shared-initialize" "f_shared.htm") + ("shiftf" "m_shiftf.htm") + ("short-float" "t_short_.htm") + ("short-float-epsilon" "v_short_.htm") + ("short-float-negative-epsilon" "v_short_.htm") + ("short-site-name" "f_short_.htm") + ("signal" "f_signal.htm") + ("signed-byte" "t_sgn_by.htm") + ("signum" "f_signum.htm") + ("simple-array" "t_smp_ar.htm") + ("simple-base-string" "t_smp_ba.htm") + ("simple-bit-vector" "t_smp_bt.htm") + ("simple-bit-vector-p" "f_smp_bt.htm") + ("simple-condition" "e_smp_cn.htm") + ("simple-condition-format-arguments" "f_smp_cn.htm") + ("simple-condition-format-control" "f_smp_cn.htm") + ("simple-error" "e_smp_er.htm") + ("simple-string" "t_smp_st.htm") + ("simple-string-p" "f_smp_st.htm") + ("simple-type-error" "e_smp_tp.htm") + ("simple-vector" "t_smp_ve.htm") + ("simple-vector-p" "f_smp_ve.htm") + ("simple-warning" "e_smp_wa.htm") + ("sin" "f_sin_c.htm") + ("single-float" "t_short_.htm") + ("single-float-epsilon" "v_short_.htm") + ("single-float-negative-epsilon" "v_short_.htm") + ("sinh" "f_sinh_.htm") + ("sixth" "f_firstc.htm") + ("sleep" "f_sleep.htm") + ("slot-boundp" "f_slt_bo.htm") + ("slot-exists-p" "f_slt_ex.htm") + ("slot-makunbound" "f_slt_ma.htm") + ("slot-missing" "f_slt_mi.htm") + ("slot-unbound" "f_slt_un.htm") + ("slot-value" "f_slt_va.htm") + ("software-type" "f_sw_tpc.htm") + ("software-version" "f_sw_tpc.htm") + ("some" "f_everyc.htm") + ("sort" "f_sort_.htm") + ("space" "d_optimi.htm") + ("special" "d_specia.htm") + ("special-operator-p" "f_specia.htm") + ("speed" "d_optimi.htm") + ("sqrt" "f_sqrt_.htm") + ("stable-sort" "f_sort_.htm") + ("standard" "07_ffb.htm") + ("standard-char" "t_std_ch.htm") + ("standard-char-p" "f_std_ch.htm") + ("standard-class" "t_std_cl.htm") + ("standard-generic-function" "t_std_ge.htm") + ("standard-method" "t_std_me.htm") + ("standard-object" "t_std_ob.htm") + ("step" "m_step.htm") + ("storage-condition" "e_storag.htm") + ("store-value" "a_store_.htm") + ("stream" "t_stream.htm") + ("stream-element-type" "f_stm_el.htm") + ("stream-error" "e_stm_er.htm") + ("stream-error-stream" "f_stm_er.htm") + ("stream-external-format" "f_stm_ex.htm") + ("streamp" "f_stmp.htm") + ("string" "a_string.htm") + ("string-capitalize" "f_stg_up.htm") + ("string-downcase" "f_stg_up.htm") + ("string-equal" "f_stgeq_.htm") + ("string-greaterp" "f_stgeq_.htm") + ("string-left-trim" "f_stg_tr.htm") + ("string-lessp" "f_stgeq_.htm") + ("string-not-equal" "f_stgeq_.htm") + ("string-not-greaterp" "f_stgeq_.htm") + ("string-not-lessp" "f_stgeq_.htm") + ("string-right-trim" "f_stg_tr.htm") + ("string-stream" "t_stg_st.htm") + ("string-trim" "f_stg_tr.htm") + ("string-upcase" "f_stg_up.htm") + ("string/=" "f_stgeq_.htm") + ("string<" "f_stgeq_.htm") + ("string<=" "f_stgeq_.htm") + ("string=" "f_stgeq_.htm") + ("string>" "f_stgeq_.htm") + ("string>=" "f_stgeq_.htm") + ("stringp" "f_stgp.htm") + ("structure" "f_docume.htm") + ("structure-class" "t_stu_cl.htm") + ("structure-object" "t_stu_ob.htm") + ("style-warning" "e_style_.htm") + ("sublis" "f_sublis.htm") + ("subseq" "f_subseq.htm") + ("subsetp" "f_subset.htm") + ("subst" "f_substc.htm") + ("subst-if" "f_substc.htm") + ("subst-if-not" "f_substc.htm") + ("substitute" "f_sbs_s.htm") + ("substitute-if" "f_sbs_s.htm") + ("substitute-if-not" "f_sbs_s.htm") + ("subtypep" "f_subtpp.htm") + ("svref" "f_svref.htm") + ("sxhash" "f_sxhash.htm") + ("symbol" "t_symbol.htm") + ("symbol-function" "f_symb_1.htm") + ("symbol-macrolet" "s_symbol.htm") + ("symbol-name" "f_symb_2.htm") + ("symbol-package" "f_symb_3.htm") + ("symbol-plist" "f_symb_4.htm") + ("symbol-value" "f_symb_5.htm") + ("symbolp" "f_symbol.htm") + ("synonym-stream" "t_syn_st.htm") + ("synonym-stream-symbol" "f_syn_st.htm") + ("t" "a_t.htm") + ("tagbody" "s_tagbod.htm") + ("tailp" "f_ldiffc.htm") + ("tan" "f_sin_c.htm") + ("tanh" "f_sinh_.htm") + ("tenth" "f_firstc.htm") + ("terpri" "f_terpri.htm") + ("the" "s_the.htm") + ("third" "f_firstc.htm") + ("throw" "s_throw.htm") + ("time" "m_time.htm") + ("trace" "m_tracec.htm") + ("translate-logical-pathname" "f_tr_log.htm") + ("translate-pathname" "f_tr_pn.htm") + ("tree-equal" "f_tree_e.htm") + ("truename" "f_tn.htm") + ("truncate" "f_floorc.htm") + ("two-way-stream" "t_two_wa.htm") + ("two-way-stream-input-stream" "f_two_wa.htm") + ("two-way-stream-output-stream" "f_two_wa.htm") + ("type" "a_type.htm") + ("type-error" "e_tp_err.htm") + ("type-error-datum" "f_tp_err.htm") + ("type-error-expected-type" "f_tp_err.htm") + ("type-of" "f_tp_of.htm") + ("typecase" "m_tpcase.htm") + ("typep" "f_typep.htm") + ("unbound-slot" "e_unboun.htm") + ("unbound-slot-instance" "f_unboun.htm") + ("unbound-variable" "e_unbo_1.htm") + ("undefined-function" "e_undefi.htm") + ("unexport" "f_unexpo.htm") + ("unintern" "f_uninte.htm") + ("union" "f_unionc.htm") + ("unless" "m_when_.htm") + ("unread-char" "f_unrd_c.htm") + ("unsigned-byte" "t_unsgn_.htm") + ("untrace" "m_tracec.htm") + ("unuse-package" "f_unuse_.htm") + ("unwind-protect" "s_unwind.htm") + ("update-instance-for-different-class" "f_update.htm") + ("update-instance-for-redefined-class" "f_upda_1.htm") + ("upgraded-array-element-type" "f_upgr_1.htm") + ("upgraded-complex-part-type" "f_upgrad.htm") + ("upper-case-p" "f_upper_.htm") + ("use-package" "f_use_pk.htm") + ("use-value" "a_use_va.htm") + ("user-homedir-pathname" "f_user_h.htm") + ("values" "a_values.htm") + ("values-list" "f_vals_l.htm") + ("variable" "f_docume.htm") + ("vector" "a_vector.htm") + ("vector-pop" "f_vec_po.htm") + ("vector-push" "f_vec_ps.htm") + ("vector-push-extend" "f_vec_ps.htm") + ("vectorp" "f_vecp.htm") + ("warn" "f_warn.htm") + ("warning" "e_warnin.htm") + ("when" "m_when_.htm") + ("wild-pathname-p" "f_wild_p.htm") + ("with-accessors" "m_w_acce.htm") + ("with-compilation-unit" "m_w_comp.htm") + ("with-condition-restarts" "m_w_cnd_.htm") + ("with-hash-table-iterator" "m_w_hash.htm") + ("with-input-from-string" "m_w_in_f.htm") + ("with-open-file" "m_w_open.htm") + ("with-open-stream" "m_w_op_1.htm") + ("with-output-to-string" "m_w_out_.htm") + ("with-package-iterator" "m_w_pkg_.htm") + ("with-simple-restart" "m_w_smp_.htm") + ("with-slots" "m_w_slts.htm") + ("with-standard-io-syntax" "m_w_std_.htm") + ("write" "f_wr_pr.htm") + ("write-byte" "f_wr_by.htm") + ("write-char" "f_wr_cha.htm") + ("write-line" "f_wr_stg.htm") + ("write-sequence" "f_wr_seq.htm") + ("write-string" "f_wr_stg.htm") + ("write-to-string" "f_wr_to_.htm") + ("y-or-n-p" "f_y_or_n.htm") + ("yes-or-no-p" "f_y_or_n.htm") + ("zerop" "f_zerop.htm")))) + +;;; FORMAT character lookup by Frode Vatvedt Fjeld <frodef(a)acm.org> 20030902 +;;; +;;; adjusted for ILISP by Nikodemus Siivola 20030903 + +(defvar common-lisp-hyperspec-format-history nil + "History of format characters looked up in the Common Lisp HyperSpec.") + +(defvar common-lisp-hyperspec-format-characters (make-vector 67 0)) + + +(defun common-lisp-hyperspec-section-6.0 (indices) + (let ((string (format "%sBody/%s_" + common-lisp-hyperspec-root + (let ((base (pop indices))) + (if (< base 10) + (format "0%s" base) + base))))) + (concat string + (mapconcat (lambda (n) + (make-string 1 (+ ?a (- n 1)))) + indices + "") + ".htm"))) + +(defun common-lisp-hyperspec-section-4.0 (indices) + (let ((string (format "%sBody/sec_" + common-lisp-hyperspec-root))) + (concat string + (mapconcat (lambda (n) + (format "%d" n)) + indices + "-") + ".html"))) + +(defvar common-lisp-hyperspec-section-fun 'common-lisp-hyperspec-section-6.0) + +(defun common-lisp-hyperspec-section (indices) + (funcall common-lisp-hyperspec-section-fun indices)) + +(defun common-lisp-hyperspec-format (character-name) + (interactive + (list (let ((char-at-point + (ignore-errors (char-to-string (char-after (point)))))) + (if (and char-at-point + (intern-soft (upcase char-at-point) + common-lisp-hyperspec-format-characters)) + char-at-point + (completing-read + "Look up format control character in Common Lisp HyperSpec: " + common-lisp-hyperspec-format-characters nil #'boundp + nil nil 'common-lisp-hyperspec-format-history))))) + (maplist (lambda (entry) + (browse-url (common-lisp-hyperspec-section (car entry)))) + (let ((symbol (intern-soft character-name + common-lisp-hyperspec-format-characters))) + (if (and symbol (boundp symbol)) + (symbol-value symbol) + (error "The symbol `%s' is not defined in Common Lisp" + character-name))))) + +(eval-when (load eval) + (defalias 'hyperspec-lookup-format 'common-lisp-hyperspec-format)) + +(mapcar (lambda (entry) + (let ((symbol (intern (car entry) + common-lisp-hyperspec-format-characters))) + (if (boundp symbol) + (pushnew (cadr entry) (symbol-value symbol) :test 'equal) + (set symbol (cdr entry)))) + (when (and (= 1 (length (car entry))) + (not (string-equal (car entry) (upcase (car entry))))) + (let ((symbol (intern (upcase (car entry)) + common-lisp-hyperspec-format-characters))) + (if (boundp symbol) + (pushnew (cadr entry) (symbol-value symbol) :test 'equal) + (set symbol (cdr entry)))))) + '(("c" (22 3 1 1)) ("C: Character" (22 3 1 1)) + ("%" (22 3 1 2)) ("Percent: Newline" (22 3 1 2)) + ("&" (22 3 1 3)) ("Ampersand: Fresh-line" (22 3 1 3)) + ("|" (22 3 1 4)) ("Vertical-Bar: Page" (22 3 1 4)) + ("~" (22 3 1 5)) ("Tilde: Tilde" (22 3 1 5)) + ("r" (22 3 2 1)) ("R: Radix" (22 3 2 1)) + ("d" (22 3 2 2)) ("D: Decimal" (22 3 2-2)) + ("b" (22 3 2 3)) ("B: Binary" (22 3 2 3)) + ("o" (22 3 2 4)) ("O: Octal" (22 3 2 4)) + ("x" (22 3 2 5)) ("X: Hexadecimal" (22 3 2 5)) + ("f" (22 3 3 1)) ("F: Fixed-Format Floating-Point" (22 3 3 1)) + ("e" (22 3 3 2)) ("E: Exponential Floating-Point" (22 3 3 2)) + ("g" (22 3 3 3)) ("G: General Floating-Point" (22 3 3 3)) + ("$" (22 3 3 4)) ("Dollarsign: Monetary Floating-Point" (22 3 3 4)) + ("a" (22 3 4 1)) ("A: Aesthetic" (22 3 4 1)) + ("s" (22 3 4 2)) ("S: Standard" (22 3 4 2)) + ("w" (22 3 4 3)) ("W: Write" (22 3 4 3)) + ("_" (22 3 5 1)) ("Underscore: Conditional Newline" (22 3 5 1)) + ("<" (22 3 5 2)) ("Less-Than-Sign: Logical Block" (22 3 5 2)) + ("i" (22 3 5 3)) ("I: Indent" (22 3 5 3)) + ("/" (22 3 5 4)) ("Slash: Call Function" (22 3 5 4)) + ("t" (22 3 6 1)) ("T: Tabulate" (22 3 6 1)) + ("<" (22 3 6 2)) ("Less-Than-Sign: Justification" (22 3 6 2)) + (">" (22 3 6 3)) ("Greater-Than-Sign: End of Justification" (22 3 6 3)) + ("*" (22 3 7 1)) ("Asterisk: Go-To" (22 3 7 1)) + ("[" (22 3 7 2)) ("Left-Bracket: Conditional Expression" (22 3 7 2)) + ("]" (22 3 7 3)) ("Right-Bracket: End of Conditional Expression" (22 3 7 3)) + ("{" (22 3 7 4)) ("Left-Brace: Iteration" (22 3 7 4)) + ("}" (22 3 7 5)) ("Right-Brace: End of Iteration" (22 3 7 5)) + ("?" (22 3 7 6)) ("Question-Mark: Recursive Processing" (22 3 7 6)) + ("(" (22 3 8 1)) ("Left-Paren: Case Conversion" (22 3 8 1)) + (")" (22 3 8 2)) ("Right-Paren: End of Case Conversion" (22 3 8 2)) + ("p" (22 3 8 3)) ("P: Plural" (22 3 8-3)) + (";" (22 3 9 1)) ("Semicolon: Clause Separator" (22 3 9 1)) + ("^" (22 3 9 2)) ("Circumflex: Escape Upward" (22 3 9 2)) + ("Newline: Ignored Newline" (22 3 9 3)) + ("Nesting of FORMAT Operations" (22 3 10 1)) + ("Missing and Additional FORMAT Arguments" (22 3 10 2)) + ("Additional FORMAT Parameters" (22 3 10 3)))) + +(defvar common-lisp-glossary-fun 'common-lisp-glossary-6.0) + +(defun common-lisp-glossary-6.0 (string) + (format "%sBody/26_glo_%s.htm#%s" + common-lisp-hyperspec-root + (let ((char (string-to-char string))) + (if (and (<= ?a char) + (<= char ?z)) + (make-string 1 char) + "9")) + (subst-char-in-string ?\ ?_ string))) + +(defun common-lisp-glossary-4.0 (string) + (format "%sBody/glo_%s.html#%s" + common-lisp-hyperspec-root + (let ((char (string-to-char string))) + (if (and (<= ?a char) + (<= char ?z)) + (make-string 1 char) + "9")) + (subst-char-in-string ?\ ?_ string))) + +(defvar common-lisp-hyperspec-issuex-table nil + "The HyperSpec IssueX table file. If you copy the HyperSpec to your +local system, set this variable to the location of the Issue +cross-references table which is usually \"Map_IssX.txt\" or +\"Issue-Cross-Refs.text\".") + +(defvar common-lisp-hyperspec-issuex-symbols (make-vector 67 0)) + +(if common-lisp-hyperspec-issuex-table + (let ((index-buffer (find-file-noselect common-lisp-hyperspec-issuex-table))) + (labels ((get-one-line () + (prog1 + (delete* ?\n (thing-at-point 'line)) + (forward-line)))) + (save-excursion + (set-buffer index-buffer) + (goto-char (point-min)) + (while (< (point) (point-max)) + (let* ((symbol (intern (downcase (get-one-line)) + common-lisp-hyperspec-issuex-symbols)) + (relative-url (get-one-line))) + (set symbol (subseq relative-url + (1+ (position ?\/ relative-url :from-end t))))))))) + (mapcar + (lambda (entry) + (let ((symbol (intern (car entry) common-lisp-hyperspec-issuex-symbols))) + (set symbol (cadr entry)))) + '(("&environment-binding-order:first" "iss001.htm") + ("access-error-name" "iss002.htm") + ("adjust-array-displacement" "iss003.htm") + ("adjust-array-fill-pointer" "iss004.htm") + ("adjust-array-not-adjustable:implicit-copy" "iss005.htm") + ("allocate-instance:add" "iss006.htm") + ("allow-local-inline:inline-notinline" "iss007.htm") + ("allow-other-keys-nil:permit" "iss008.htm") + ("aref-1d" "iss009.htm") + ("argument-mismatch-error-again:consistent" "iss010.htm") + ("argument-mismatch-error-moon:fix" "iss011.htm") + ("argument-mismatch-error:more-clarifications" "iss012.htm") + ("arguments-underspecified:specify" "iss013.htm") + ("array-dimension-limit-implications:all-fixnum" "iss014.htm") + ("array-type-element-type-semantics:unify-upgrading" "iss015.htm") + ("assert-error-type:error" "iss016.htm") + ("assoc-rassoc-if-key" "iss017.htm") + ("assoc-rassoc-if-key:yes" "iss018.htm") + ("boa-aux-initialization:error-on-read" "iss019.htm") + ("break-on-warnings-obsolete:remove" "iss020.htm") + ("broadcast-stream-return-values:clarify-minimally" "iss021.htm") + ("butlast-negative:should-signal" "iss022.htm") + ("change-class-initargs:permit" "iss023.htm") + ("char-name-case:x3j13-mar-91" "iss024.htm") + ("character-loose-ends:fix" "iss025.htm") + ("character-proposal:2" "iss026.htm") + ("character-proposal:2-1-1" "iss027.htm") + ("character-proposal:2-1-2" "iss028.htm") + ("character-proposal:2-2-1" "iss029.htm") + ("character-proposal:2-3-1" "iss030.htm") + ("character-proposal:2-3-2" "iss031.htm") + ("character-proposal:2-3-3" "iss032.htm") + ("character-proposal:2-3-4" "iss033.htm") + ("character-proposal:2-3-5" "iss034.htm") + ("character-proposal:2-3-6" "iss035.htm") + ("character-proposal:2-4-1" "iss036.htm") + ("character-proposal:2-4-2" "iss037.htm") + ("character-proposal:2-4-3" "iss038.htm") + ("character-proposal:2-5-2" "iss039.htm") + ("character-proposal:2-5-6" "iss040.htm") + ("character-proposal:2-5-7" "iss041.htm") + ("character-proposal:2-6-1" "iss042.htm") + ("character-proposal:2-6-2" "iss043.htm") + ("character-proposal:2-6-3" "iss044.htm") + ("character-proposal:2-6-5" "iss045.htm") + ("character-vs-char:less-inconsistent-short" "iss046.htm") + ("class-object-specializer:affirm" "iss047.htm") + ("clos-conditions-again:allow-subset" "iss048.htm") + ("clos-conditions:integrate" "iss049.htm") + ("clos-error-checking-order:no-applicable-method-first" "iss050.htm") + ("clos-macro-compilation:minimal" "iss051.htm") + ("close-constructed-stream:argument-stream-only" "iss052.htm") + ("closed-stream-operations:allow-inquiry" "iss053.htm") + ("coercing-setf-name-to-function:all-function-names" "iss054.htm") + ("colon-number" "iss055.htm") + ("common-features:specify" "iss056.htm") + ("common-type:remove" "iss057.htm") + ("compile-argument-problems-again:fix" "iss058.htm") + ("compile-file-handling-of-top-level-forms:clarify" "iss059.htm") + ("compile-file-output-file-defaults:input-file" "iss060.htm") + ("compile-file-package" "iss061.htm") + ("compile-file-pathname-arguments:make-consistent" "iss062.htm") + ("compile-file-symbol-handling:new-require-consistency" "iss063.htm") + ("compiled-function-requirements:tighten" "iss064.htm") + ("compiler-diagnostics:use-handler" "iss065.htm") + ("compiler-let-confusion:eliminate" "iss066.htm") + ("compiler-verbosity:like-load" "iss067.htm") + ("compiler-warning-stream" "iss068.htm") + ("complex-atan-branch-cut:tweak" "iss069.htm") + ("complex-atanh-bogus-formula:tweak-more" "iss070.htm") + ("complex-rational-result:extend" "iss071.htm") + ("compute-applicable-methods:generic" "iss072.htm") + ("concatenate-sequence:signal-error" "iss073.htm") + ("condition-accessors-setfable:no" "iss074.htm") + ("condition-restarts:buggy" "iss075.htm") + ("condition-restarts:permit-association" "iss076.htm") + ("condition-slots:hidden" "iss077.htm") + ("cons-type-specifier:add" "iss078.htm") + ("constant-circular-compilation:yes" "iss079.htm") + ("constant-collapsing:generalize" "iss080.htm") + ("constant-compilable-types:specify" "iss081.htm") + ("constant-function-compilation:no" "iss082.htm") + ("constant-modification:disallow" "iss083.htm") + ("constantp-definition:intentional" "iss084.htm") + ("constantp-environment:add-arg" "iss085.htm") + ("contagion-on-numerical-comparisons:transitive" "iss086.htm") + ("copy-symbol-copy-plist:copy-list" "iss087.htm") + ("copy-symbol-print-name:equal" "iss088.htm") + ("data-io:add-support" "iss089.htm") + ("data-types-hierarchy-underspecified" "iss090.htm") + ("debugger-hook-vs-break:clarify" "iss091.htm") + ("declaration-scope:no-hoisting" "iss092.htm") + ("declare-array-type-element-references:restrictive" "iss093.htm") + ("declare-function-ambiguity:delete-ftype-abbreviation" "iss094.htm") + ("declare-macros:flush" "iss095.htm") + ("declare-type-free:lexical" "iss096.htm") + ("decls-and-doc" "iss097.htm") + ("decode-universal-time-daylight:like-encode" "iss098.htm") + ("defconstant-special:no" "iss099.htm") + ("defgeneric-declare:allow-multiple" "iss100.htm") + ("define-compiler-macro:x3j13-nov89" "iss101.htm") + ("define-condition-syntax:incompatibly-more-like-defclass+emphasize-read-only" "iss102.htm") + ("define-method-combination-behavior:clarify" "iss103.htm") + ("defining-macros-non-top-level:allow" "iss104.htm") + ("defmacro-block-scope:excludes-bindings" "iss105.htm") + ("defmacro-lambda-list:tighten-description" "iss106.htm") + ("defmethod-declaration-scope:corresponds-to-bindings" "iss107.htm") + ("defpackage:addition" "iss108.htm") + ("defstruct-constructor-key-mixture:allow-key" "iss109.htm") + ("defstruct-constructor-options:explicit" "iss110.htm") + ("defstruct-constructor-slot-variables:not-bound" "iss111.htm") + ("defstruct-copier-argument-type:restrict" "iss112.htm") + ("defstruct-copier:argument-type" "iss113.htm") + ("defstruct-default-value-evaluation:iff-needed" "iss114.htm") + ("defstruct-include-deftype:explicitly-undefined" "iss115.htm") + ("defstruct-print-function-again:x3j13-mar-93" "iss116.htm") + ("defstruct-print-function-inheritance:yes" "iss117.htm") + ("defstruct-redefinition:error" "iss118.htm") + ("defstruct-slots-constraints-name:duplicates-error" "iss119.htm") + ("defstruct-slots-constraints-number" "iss120.htm") + ("deftype-destructuring:yes" "iss121.htm") + ("deftype-key:allow" "iss122.htm") + ("defvar-documentation:unevaluated" "iss123.htm") + ("defvar-init-time:not-delayed" "iss124.htm") + ("defvar-initialization:conservative" "iss125.htm") + ("deprecation-position:limited" "iss126.htm") + ("describe-interactive:no" "iss127.htm") + ("describe-underspecified:describe-object" "iss128.htm") + ("destructive-operations:specify" "iss129.htm") + ("destructuring-bind:new-macro" "iss130.htm") + ("disassemble-side-effect:do-not-install" "iss131.htm") + ("displaced-array-predicate:add" "iss132.htm") + ("do-symbols-block-scope:entire-form" "iss133.htm") + ("do-symbols-duplicates" "iss134.htm") + ("documentation-function-bugs:fix" "iss135.htm") + ("documentation-function-tangled:require-argument" "iss136.htm") + ("dotimes-ignore:x3j13-mar91" "iss137.htm") + ("dotted-list-arguments:clarify" "iss138.htm") + ("dotted-macro-forms:allow" "iss139.htm") + ("dribble-technique" "iss140.htm") + ("dynamic-extent-function:extend" "iss141.htm") + ("dynamic-extent:new-declaration" "iss142.htm") + ("equal-structure:maybe-status-quo" "iss143.htm") + ("error-terminology-warning:might" "iss144.htm") + ("eval-other:self-evaluate" "iss145.htm") + ("eval-top-level:load-like-compile-file" "iss146.htm") + ("eval-when-non-top-level:generalize-eval-new-keywords" "iss147.htm") + ("eval-when-obsolete-keywords:x3j13-mar-1993" "iss148.htm") + ("evalhook-step-confusion:fix" "iss149.htm") + ("evalhook-step-confusion:x3j13-nov-89" "iss150.htm") + ("exit-extent-and-condition-system:like-dynamic-bindings" "iss151.htm") + ("exit-extent:minimal" "iss152.htm") + ("expt-ratio:p.211" "iss153.htm") + ("extensions-position:documentation" "iss154.htm") + ("external-format-for-every-file-connection:minimum" "iss155.htm") + ("extra-return-values:no" "iss156.htm") + ("file-open-error:signal-file-error" "iss157.htm") + ("fixnum-non-portable:tighten-definition" "iss158.htm") + ("flet-declarations" "iss159.htm") + ("flet-declarations:allow" "iss160.htm") + ("flet-implicit-block:yes" "iss161.htm") + ("float-underflow:add-variables" "iss162.htm") + ("floating-point-condition-names:x3j13-nov-89" "iss163.htm") + ("format-atsign-colon" "iss164.htm") + ("format-colon-uparrow-scope" "iss165.htm") + ("format-comma-interval" "iss166.htm") + ("format-e-exponent-sign:force-sign" "iss167.htm") + ("format-op-c" "iss168.htm") + ("format-pretty-print:yes" "iss169.htm") + ("format-string-arguments:specify" "iss170.htm") + ("function-call-evaluation-order:more-unspecified" "iss171.htm") + ("function-composition:jan89-x3j13" "iss172.htm") + ("function-definition:jan89-x3j13" "iss173.htm") + ("function-name:large" "iss174.htm") + ("function-type" "iss175.htm") + ("function-type-argument-type-semantics:restrictive" "iss176.htm") + ("function-type-key-name:specify-keyword" "iss177.htm") + ("function-type-rest-list-element:use-actual-argument-type" "iss178.htm") + ("function-type:x3j13-march-88" "iss179.htm") + ("generalize-pretty-printer:unify" "iss180.htm") + ("generic-flet-poorly-designed:delete" "iss181.htm") + ("gensym-name-stickiness:like-teflon" "iss182.htm") + ("gentemp-bad-idea:deprecate" "iss183.htm") + ("get-macro-character-readtable:nil-standard" "iss184.htm") + ("get-setf-method-environment:add-arg" "iss185.htm") + ("hash-table-access:x3j13-mar-89" "iss186.htm") + ("hash-table-key-modification:specify" "iss187.htm") + ("hash-table-package-generators:add-with-wrapper" "iss188.htm") + ("hash-table-rehash-size-integer" "iss189.htm") + ("hash-table-size:intended-entries" "iss190.htm") + ("hash-table-tests:add-equalp" "iss191.htm") + ("ieee-atan-branch-cut:split" "iss192.htm") + ("ignore-use-terminology:value-only" "iss193.htm") + ("import-setf-symbol-package" "iss194.htm") + ("in-package-functionality:mar89-x3j13" "iss195.htm") + ("in-syntax:minimal" "iss196.htm") + ("initialization-function-keyword-checking" "iss197.htm") + ("iso-compatibility:add-substrate" "iss198.htm") + ("jun90-trivial-issues:11" "iss199.htm") + ("jun90-trivial-issues:14" "iss200.htm") + ("jun90-trivial-issues:24" "iss201.htm") + ("jun90-trivial-issues:25" "iss202.htm") + ("jun90-trivial-issues:27" "iss203.htm") + ("jun90-trivial-issues:3" "iss204.htm") + ("jun90-trivial-issues:4" "iss205.htm") + ("jun90-trivial-issues:5" "iss206.htm") + ("jun90-trivial-issues:9" "iss207.htm") + ("keyword-argument-name-package:any" "iss208.htm") + ("last-n" "iss209.htm") + ("lcm-no-arguments:1" "iss210.htm") + ("lexical-construct-global-definition:undefined" "iss211.htm") + ("lisp-package-name:common-lisp" "iss212.htm") + ("lisp-symbol-redefinition-again:more-fixes" "iss213.htm") + ("lisp-symbol-redefinition:mar89-x3j13" "iss214.htm") + ("load-objects:make-load-form" "iss215.htm") + ("load-time-eval:r**2-new-special-form" "iss216.htm") + ("load-time-eval:r**3-new-special-form" "iss217.htm") + ("load-truename:new-pathname-variables" "iss218.htm") + ("locally-top-level:special-form" "iss219.htm") + ("loop-and-discrepancy:no-reiteration" "iss220.htm") + ("loop-for-as-on-typo:fix-typo" "iss221.htm") + ("loop-initform-environment:partial-interleaving-vague" "iss222.htm") + ("loop-miscellaneous-repairs:fix" "iss223.htm") + ("loop-named-block-nil:override" "iss224.htm") + ("loop-present-symbols-typo:flush-wrong-words" "iss225.htm") + ("loop-syntax-overhaul:repair" "iss226.htm") + ("macro-as-function:disallow" "iss227.htm") + ("macro-declarations:make-explicit" "iss228.htm") + ("macro-environment-extent:dynamic" "iss229.htm") + ("macro-function-environment" "iss230.htm") + ("macro-function-environment:yes" "iss231.htm") + ("macro-subforms-top-level-p:add-constraints" "iss232.htm") + ("macroexpand-hook-default:explicitly-vague" "iss233.htm") + ("macroexpand-hook-initial-value:implementation-dependent" "iss234.htm") + ("macroexpand-return-value:true" "iss235.htm") + ("make-load-form-confusion:rewrite" "iss236.htm") + ("make-load-form-saving-slots:no-initforms" "iss237.htm") + ("make-package-use-default:implementation-dependent" "iss238.htm") + ("map-into:add-function" "iss239.htm") + ("mapping-destructive-interaction:explicitly-vague" "iss240.htm") + ("metaclass-of-system-class:unspecified" "iss241.htm") + ("method-combination-arguments:clarify" "iss242.htm") + ("method-initform:forbid-call-next-method" "iss243.htm") + ("muffle-warning-condition-argument" "iss244.htm") + ("multiple-value-setq-order:like-setf-of-values" "iss245.htm") + ("multiple-values-limit-on-variables:undefined" "iss246.htm") + ("nintersection-destruction" "iss247.htm") + ("nintersection-destruction:revert" "iss248.htm") + ("not-and-null-return-value:x3j13-mar-93" "iss249.htm") + ("nth-value:add" "iss250.htm") + ("optimize-debug-info:new-quality" "iss251.htm") + ("package-clutter:reduce" "iss252.htm") + ("package-deletion:new-function" "iss253.htm") + ("package-function-consistency:more-permissive" "iss254.htm") + ("parse-error-stream:split-types" "iss255.htm") + ("pathname-component-case:keyword-argument" "iss256.htm") + ("pathname-component-value:specify" "iss257.htm") + ("pathname-host-parsing:recognize-logical-host-names" "iss258.htm") + ("pathname-logical:add" "iss259.htm") + ("pathname-print-read:sharpsign-p" "iss260.htm") + ("pathname-stream" "iss261.htm") + ("pathname-stream:files-or-synonym" "iss262.htm") + ("pathname-subdirectory-list:new-representation" "iss263.htm") + ("pathname-symbol" "iss264.htm") + ("pathname-syntax-error-time:explicitly-vague" "iss265.htm") + ("pathname-unspecific-component:new-token" "iss266.htm") + ("pathname-wild:new-functions" "iss267.htm") + ("peek-char-read-char-echo:first-read-char" "iss268.htm") + ("plist-duplicates:allow" "iss269.htm") + ("pretty-print-interface" "iss270.htm") + ("princ-readably:x3j13-dec-91" "iss271.htm") + ("print-case-behavior:clarify" "iss272.htm") + ("print-case-print-escape-interaction:vertical-bar-rule-no-upcase" "iss273.htm") + ("print-circle-shared:respect-print-circle" "iss274.htm") + ("print-circle-structure:user-functions-work" "iss275.htm") + ("print-readably-behavior:clarify" "iss276.htm") + ("printer-whitespace:just-one-space" "iss277.htm") + ("proclaim-etc-in-compile-file:new-macro" "iss278.htm") + ("push-evaluation-order:first-item" "iss279.htm") + ("push-evaluation-order:item-first" "iss280.htm") + ("pushnew-store-required:unspecified" "iss281.htm") + ("quote-semantics:no-copying" "iss282.htm") + ("range-of-count-keyword:nil-or-integer" "iss283.htm") + ("range-of-start-and-end-parameters:integer-and-integer-nil" "iss284.htm") + ("read-and-write-bytes:new-functions" "iss285.htm") + ("read-case-sensitivity:readtable-keywords" "iss286.htm") + ("read-modify-write-evaluation-order:delayed-access-stores" "iss287.htm") + ("read-suppress-confusing:generalize" "iss288.htm") + ("reader-error:new-type" "iss289.htm") + ("real-number-type:x3j13-mar-89" "iss290.htm") + ("recursive-deftype:explicitly-vague" "iss291.htm") + ("reduce-argument-extraction" "iss292.htm") + ("remf-destruction-unspecified:x3j13-mar-89" "iss293.htm") + ("require-pathname-defaults-again:x3j13-dec-91" "iss294.htm") + ("require-pathname-defaults-yet-again:restore-argument" "iss295.htm") + ("require-pathname-defaults:eliminate" "iss296.htm") + ("rest-list-allocation:may-share" "iss297.htm") + ("result-lists-shared:specify" "iss298.htm") + ("return-values-unspecified:specify" "iss299.htm") + ("room-default-argument:new-value" "iss300.htm") + ("self-modifying-code:forbid" "iss301.htm") + ("sequence-type-length:must-match" "iss302.htm") + ("setf-apply-expansion:ignore-expander" "iss303.htm") + ("setf-find-class:allow-nil" "iss304.htm") + ("setf-functions-again:minimal-changes" "iss305.htm") + ("setf-get-default:evaluated-but-ignored" "iss306.htm") + ("setf-macro-expansion:last" "iss307.htm") + ("setf-method-vs-setf-method:rename-old-terms" "iss308.htm") + ("setf-multiple-store-variables:allow" "iss309.htm") + ("setf-of-apply:only-aref-and-friends" "iss310.htm") + ("setf-of-values:add" "iss311.htm") + ("setf-sub-methods:delayed-access-stores" "iss312.htm") + ("shadow-already-present" "iss313.htm") + ("shadow-already-present:works" "iss314.htm") + ("sharp-comma-confusion:remove" "iss315.htm") + ("sharp-o-foobar:consequences-undefined" "iss316.htm") + ("sharp-star-delimiter:normal-delimiter" "iss317.htm") + ("sharpsign-plus-minus-package:keyword" "iss318.htm") + ("slot-missing-values:specify" "iss319.htm") + ("slot-value-metaclasses:less-minimal" "iss320.htm") + ("special-form-p-misnomer:rename" "iss321.htm") + ("special-type-shadowing:clarify" "iss322.htm") + ("standard-input-initial-binding:defined-contracts" "iss323.htm") + ("standard-repertoire-gratuitous:rename" "iss324.htm") + ("step-environment:current" "iss325.htm") + ("step-minimal:permit-progn" "iss326.htm") + ("stream-access:add-types-accessors" "iss327.htm") + ("stream-capabilities:interactive-stream-p" "iss328.htm") + ("string-coercion:make-consistent" "iss329.htm") + ("string-output-stream-bashing:undefined" "iss330.htm") + ("structure-read-print-syntax:keywords" "iss331.htm") + ("subseq-out-of-bounds" "iss332.htm") + ("subseq-out-of-bounds:is-an-error" "iss333.htm") + ("subsetting-position:none" "iss334.htm") + ("subtypep-environment:add-arg" "iss335.htm") + ("subtypep-too-vague:clarify-more" "iss336.htm") + ("sxhash-definition:similar-for-sxhash" "iss337.htm") + ("symbol-macrolet-declare:allow" "iss338.htm") + ("symbol-macrolet-semantics:special-form" "iss339.htm") + ("symbol-macrolet-type-declaration:no" "iss340.htm") + ("symbol-macros-and-proclaimed-specials:signals-an-error" "iss341.htm") + ("symbol-print-escape-behavior:clarify" "iss342.htm") + ("syntactic-environment-access:retracted-mar91" "iss343.htm") + ("tagbody-tag-expansion:no" "iss344.htm") + ("tailp-nil:t" "iss345.htm") + ("test-not-if-not:flush-all" "iss346.htm") + ("the-ambiguity:for-declaration" "iss347.htm") + ("the-values:return-number-received" "iss348.htm") + ("time-zone-non-integer:allow" "iss349.htm") + ("type-declaration-abbreviation:allow-all" "iss350.htm") + ("type-of-and-predefined-classes:type-of-handles-floats" "iss351.htm") + ("type-of-and-predefined-classes:unify-and-extend" "iss352.htm") + ("type-of-underconstrained:add-constraints" "iss353.htm") + ("type-specifier-abbreviation:x3j13-jun90-guess" "iss354.htm") + ("undefined-variables-and-functions:compromise" "iss355.htm") + ("uninitialized-elements:consequences-undefined" "iss356.htm") + ("unread-char-after-peek-char:dont-allow" "iss357.htm") + ("unsolicited-messages:not-to-system-user-streams" "iss358.htm") + ("variable-list-asymmetry:symmetrize" "iss359.htm") + ("with-added-methods:delete" "iss360.htm") + ("with-compilation-unit:new-macro" "iss361.htm") + ("with-open-file-does-not-exist:stream-is-nil" "iss362.htm") + ("with-open-file-setq:explicitly-vague" "iss363.htm") + ("with-open-file-stream-extent:dynamic-extent" "iss364.htm") + ("with-output-to-string-append-style:vector-push-extend" "iss365.htm") + ("with-standard-io-syntax-readtable:x3j13-mar-91" "iss366.htm")))) + +(defun common-lisp-issuex (issue-name) + (let ((symbol + (intern (downcase issue-name) common-lisp-hyperspec-issuex-symbols))) + (concat common-lisp-hyperspec-root "Issues/" (symbol-value symbol)))) + +(provide 'hyperspec) + +;;; hyperspec.el ends here Added: branches/trunk-reorg/thirdparty/slime/metering.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/metering.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/metering.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,1222 @@ +;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.; -*- +;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz <mkant(a)GLINDA.OZ.CS.CMU.EDU> + +;;; **************************************************************** +;;; Metering System ************************************************ +;;; **************************************************************** +;;; +;;; The Metering System is a portable Common Lisp code profiling tool. +;;; It gathers timing and consing statistics for specified functions +;;; while a program is running. +;;; +;;; The Metering System is a combination of +;;; o the Monitor package written by Chris McConnell +;;; o the Profile package written by Skef Wholey and Rob MacLachlan +;;; The two systems were merged and extended by Mark Kantrowitz. +;;; +;;; Address: Carnegie Mellon University +;;; School of Computer Science +;;; Pittsburgh, PA 15213 +;;; +;;; This code is in the public domain and is distributed without warranty +;;; of any kind. +;;; +;;; This copy is from SLIME, http://www.common-lisp.net/project/slime/ +;;; +;;; + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; 26-JUN-90 mk Merged functionality of Monitor and Profile packages. +;;; 26-JUN-90 mk Now handles both inclusive and exclusive statistics +;;; with respect to nested calls. (Allows it to subtract +;;; total monitoring overhead for each function, not just +;;; the time spent monitoring the function itself.) +;;; 26-JUN-90 mk The table is now saved so that one may manipulate +;;; the data (sorting it, etc.) even after the original +;;; source of the data has been cleared. +;;; 25-SEP-90 mk Added get-cons functions for Lucid 3.0, MACL 1.3.2 +;;; required-arguments functions for Lucid 3.0, +;;; Franz Allegro CL, and MACL 1.3.2. +;;; 25-JAN-91 mk Now uses fdefinition if available. +;;; 25-JAN-91 mk Replaced (and :allegro (not :coral)) with :excl. +;;; Much better solution for the fact that both call +;;; themselves :allegro. +;;; 5-JUL-91 mk Fixed warning to occur only when file is loaded +;;; uncompiled. +;;; 5-JUL-91 mk When many unmonitored functions, print out number +;;; instead of whole list. +;;; 24-MAR-92 mk Updated for CLtL2 compatibility. space measuring +;;; doesn't work in MCL, but fixed so that timing +;;; statistics do. +;;; 26-MAR-92 mk Updated for Lispworks. Replaced :ccl with +;;; (and :ccl (not :lispworks)). +;;; 27-MAR-92 mk Added get-cons for Allegro-V4.0. +;;; 01-JAN-93 mk v2.0 Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1, +;;; Lucid 4.0, ibcl +;;; 25-JAN-94 mk v2.1 Patches for CLISP from Bruno Haible. +;;; 01-APR-05 lgorrie Removed support for all Lisps except CLISP and OpenMCL. +;;; Purely to cut down on stale code (e.g. #+cltl2) in this +;;; version that is bundled with SLIME. +;;; +;;; + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; - Need get-cons for Allegro, AKCL. +;;; - Speed up monitoring code. Replace use of hash tables with an embedded +;;; offset in an array so that it will be faster than using gethash. +;;; (i.e., svref/closure reference is usually faster than gethash). +;;; - Beware of (get-internal-run-time) overflowing. Yikes! +;;; - Check robustness with respect to profiled functions. +;;; - Check logic of computing inclusive and exclusive time and consing. +;;; Especially wrt incf/setf comment below. Should be incf, so we +;;; sum recursive calls. +;;; - Add option to record caller statistics -- this would list who +;;; called which functions and how often. +;;; - switches to turn timing/CONSING statistics collection on/off. + + +;;; ******************************** +;;; Notes ************************** +;;; ******************************** +;;; +;;; METERING has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (16d, Python Compiler 1.0 ) :new-compiler +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; Macintosh Allegro Common Lisp (1.3.2) +;;; Macintosh Common Lisp (2.0) +;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 11/19/90) :allegro-v3.1 +;;; ExCL (Franz Allegro CL 4.0.1 [Sun4] 2/8/91) :allegro-v4.0 +;;; ExCL (Franz Allegro CL 4.1 [SPARC R1] 8/28/92 14:06) :allegro-v4.1 +;;; ExCL (Franz ACL 5.0.1 [Linux/X86] 6/29/99 16:11) :allegro-v5.0.1 +;;; Lucid CL (Version 2.1 6-DEC-87) +;;; Lucid Common Lisp (3.0) +;;; Lucid Common Lisp (4.0.1 HP-700 12-Aug-91) +;;; AKCL (1.86, June 30, 1987 or later) +;;; Ibuki Common Lisp (Version 2, release 01.027) +;;; CLISP (January 1994) +;;; +;;; METERING needs to be tested in the following lisps: +;;; Symbolics Common Lisp (8.0) +;;; KCL (June 3, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; VAXLisp (2.0, 3.1) +;;; Procyon Common Lisp + + +;;; **************************************************************** +;;; Documentation ************************************************** +;;; **************************************************************** +;;; +;;; This system runs in any valid Common Lisp. Four small +;;; implementation-dependent changes can be made to improve performance +;;; and prettiness. In the section labelled "Implementation Dependent +;;; Changes" below, you should tailor the functions REQUIRED-ARGUMENTS, +;;; GET-CONS, GET-TIME, and TIME-UNITS-PER-SECOND to your implementation +;;; for the best results. If GET-CONS is not specified for your +;;; implementation, no consing information will be reported. The other +;;; functions will default to working forms, albeit inefficient, in +;;; non-CMU implementations. If you tailor these functions for a particular +;;; version of Common Lisp, we'd appreciate receiving the code. +;;; + +;;; **************************************************************** +;;; Usage Notes **************************************************** +;;; **************************************************************** +;;; +;;; SUGGESTED USAGE: +;;; +;;; Start by monitoring big pieces of the program, then carefully choose +;;; which functions close to, but not in, the inner loop are to be +;;; monitored next. Don't monitor functions that are called by other +;;; monitored functions: you will only confuse yourself. +;;; +;;; If the per-call time reported is less than 1/10th of a second, then +;;; consider the clock resolution and profiling overhead before you believe +;;; the time. It may be that you will need to run your program many times +;;; in order to average out to a higher resolution. +;;; +;;; The easiest way to use this package is to load it and execute either +;;; (mon:with-monitoring (names*) () +;;; your-forms*) +;;; or +;;; (mon:monitor-form your-form) +;;; The former allows you to specify which functions will be monitored; the +;;; latter monitors all functions in the current package. Both automatically +;;; produce a table of statistics. Other variants can be constructed from +;;; the monitoring primitives, which are described below, along with a +;;; fuller description of these two macros. +;;; +;;; For best results, compile this file before using. +;;; +;;; +;;; CLOCK RESOLUTION: +;;; +;;; Unless you are very lucky, the length of your machine's clock "tick" is +;;; probably much longer than the time it takes a simple function to run. +;;; For example, on the IBM RT, the clock resolution is 1/50th of a second. +;;; This means that if a function is only called a few times, then only the +;;; first couple of decimal places are really meaningful. +;;; +;;; +;;; MONITORING OVERHEAD: +;;; +;;; The added monitoring code takes time to run every time that the monitored +;;; function is called, which can disrupt the attempt to collect timing +;;; information. In order to avoid serious inflation of the times for functions +;;; that take little time to run, an estimate of the overhead due to monitoring +;;; is subtracted from the times reported for each function. +;;; +;;; Although this correction works fairly well, it is not totally accurate, +;;; resulting in times that become increasingly meaningless for functions +;;; with short runtimes. For example, subtracting the estimated overhead +;;; may result in negative times for some functions. This is only a concern +;;; when the estimated profiling overhead is many times larger than +;;; reported total CPU time. +;;; +;;; If you monitor functions that are called by monitored functions, in +;;; :inclusive mode the monitoring overhead for the inner function is +;;; subtracted from the CPU time for the outer function. [We do this by +;;; counting for each function not only the number of calls to *this* +;;; function, but also the number of monitored calls while it was running.] +;;; In :exclusive mode this is not necessary, since we subtract the +;;; monitoring time of inner functions, overhead & all. +;;; +;;; Otherwise, the estimated monitoring overhead is not represented in the +;;; reported total CPU time. The sum of total CPU time and the estimated +;;; monitoring overhead should be close to the total CPU time for the +;;; entire monitoring run (as determined by TIME). +;;; +;;; A timing overhead factor is computed at load time. This will be incorrect +;;; if the monitoring code is run in a different environment than this file +;;; was loaded in. For example, saving a core image on a high performance +;;; machine and running it on a low performance one will result in the use +;;; of an erroneously small overhead factor. +;;; +;;; +;;; If your times vary widely, possible causes are: +;;; - Garbage collection. Try turning it off, then running your code. +;;; Be warned that monitoring code will probably cons when it does +;;; (get-internal-run-time). +;;; - Swapping. If you have enough memory, execute your form once +;;; before monitoring so that it will be swapped into memory. Otherwise, +;;; get a bigger machine! +;;; - Resolution of internal-time-units-per-second. If this value is +;;; too low, then the timings become wild. You can try executing more +;;; of whatever your test is, but that will only work if some of your +;;; paths do not match the timer resolution. +;;; internal-time-units-per-second is so coarse -- on a Symbolics it is +;;; 977, in MACL it is 60. +;;; +;;; + +;;; **************************************************************** +;;; Interface ****************************************************** +;;; **************************************************************** +;;; +;;; WITH-MONITORING (&rest functions) [Macro] +;;; (&optional (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time)) +;;; &body body +;;; The named functions will be set up for monitoring, the body forms executed, +;;; a table of results printed, and the functions unmonitored. The nested, +;;; threshold, and key arguments are passed to report-monitoring below. +;;; +;;; MONITOR-FORM form [Macro] +;;; &optional (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time) +;;; All functions in the current package are set up for monitoring while +;;; the form is executed, and automatically unmonitored after a table of +;;; results has been printed. The nested, threshold, and key arguments +;;; are passed to report-monitoring below. +;;; +;;; *MONITORED-FUNCTIONS* [Variable] +;;; This holds a list of all functions that are currently being monitored. +;;; +;;; MONITOR &rest names [Macro] +;;; The named functions will be set up for monitoring by augmenting +;;; their function definitions with code that gathers statistical information +;;; about code performance. As with the TRACE macro, the function names are +;;; not evaluated. Calls the function MON::MONITORING-ENCAPSULATE on each +;;; function name. If no names are specified, returns a list of all +;;; monitored functions. +;;; +;;; If name is not a symbol, it is evaled to return the appropriate +;;; closure. This allows you to monitor closures stored anywhere like +;;; in a variable, array or structure. Most other monitoring packages +;;; can't handle this. +;;; +;;; MONITOR-ALL &optional (package *package*) [Function] +;;; Monitors all functions in the specified package, which defaults to +;;; the current package. +;;; +;;; UNMONITOR &rest names [Macro] +;;; Removes monitoring code from the named functions. If no names are +;;; specified, all currently monitored functions are unmonitored. +;;; +;;; RESET-MONITORING-INFO name [Function] +;;; Resets the monitoring statistics for the specified function. +;;; +;;; RESET-ALL-MONITORING [Function] +;;; Resets the monitoring statistics for all monitored functions. +;;; +;;; MONITORED name [Function] +;;; Predicate to test whether a function is monitored. +;;; +;;; REPORT-MONITORING &optional names [Function] +;;; (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time) +;;; Creates a table of monitoring information for the specified list +;;; of names, and displays the table using display-monitoring-results. +;;; If names is :all or nil, uses all currently monitored functions. +;;; Takes the following arguments: +;;; - NESTED specifies whether nested calls of monitored functions +;;; are included in the times for monitored functions. +;;; o If :inclusive, the per-function information is for the entire +;;; duration of the monitored function, including any calls to +;;; other monitored functions. If functions A and B are monitored, +;;; and A calls B, then the accumulated time and consing for A will +;;; include the time and consing of B. Note: if a function calls +;;; itself recursively, the time spent in the inner call(s) may +;;; be counted several times. +;;; o If :exclusive, the information excludes time attributed to +;;; calls to other monitored functions. This is the default. +;;; - THRESHOLD specifies that only functions which have been executed +;;; more than threshold percent of the time will be reported. Defaults +;;; to 1%. If a threshold of 0 is specified, all functions are listed, +;;; even those with 0 or negative running times (see note on overhead). +;;; - KEY specifies that the table be sorted by one of the following +;;; sort keys: +;;; :function alphabetically by function name +;;; :percent-time by percent of total execution time +;;; :percent-cons by percent of total consing +;;; :calls by number of times the function was called +;;; :time-per-call by average execution time per function +;;; :cons-per-call by average consing per function +;;; :time same as :percent-time +;;; :cons same as :percent-cons +;;; +;;; REPORT &key (names :all) [Function] +;;; (nested :exclusive) +;;; (threshold 0.01) +;;; (sort-key :percent-time) +;;; (ignore-no-calls nil) +;;; +;;; Same as REPORT-MONITORING but we use a nicer keyword interface. +;;; +;;; DISPLAY-MONITORING-RESULTS &optional (threshold 0.01) [Function] +;;; (key :percent-time) +;;; Prints a table showing for each named function: +;;; - the total CPU time used in that function for all calls +;;; - the total number of bytes consed in that function for all calls +;;; - the total number of calls +;;; - the average amount of CPU time per call +;;; - the average amount of consing per call +;;; - the percent of total execution time spent executing that function +;;; - the percent of total consing spent consing in that function +;;; Summary totals of the CPU time, consing, and calls columns are printed. +;;; An estimate of the monitoring overhead is also printed. May be run +;;; even after unmonitoring all the functions, to play with the data. +;;; +;;; SAMPLE TABLE: +#| + Cons + % % Per Total Total +Function Time Cons Calls Sec/Call Call Time Cons +---------------------------------------------------------------------- +FIND-ROLE: 0.58 0.00 136 0.003521 0 0.478863 0 +GROUP-ROLE: 0.35 0.00 365 0.000802 0 0.292760 0 +GROUP-PROJECTOR: 0.05 0.00 102 0.000408 0 0.041648 0 +FEATURE-P: 0.02 0.00 570 0.000028 0 0.015680 0 +---------------------------------------------------------------------- +TOTAL: 1173 0.828950 0 +Estimated total monitoring overhead: 0.88 seconds +|# + +;;; **************************************************************** +;;; METERING ******************************************************* +;;; **************************************************************** + +;;; ******************************** +;;; Warn people using the wrong Lisp +;;; ******************************** + +#-(or clisp openmcl) +(warn "metering.lisp does not support your Lisp implementation!") + +;;; ******************************** +;;; Packages *********************** +;;; ******************************** + +;;; For CLtL2 compatible lisps + +(defpackage "MONITOR" (:nicknames "MON") (:use "COMMON-LISP") + (:export "*MONITORED-FUNCTIONS*" + "MONITOR" "MONITOR-ALL" "UNMONITOR" "MONITOR-FORM" + "WITH-MONITORING" + "RESET-MONITORING-INFO" "RESET-ALL-MONITORING" + "MONITORED" + "REPORT-MONITORING" + "DISPLAY-MONITORING-RESULTS" + "MONITORING-ENCAPSULATE" "MONITORING-UNENCAPSULATE" + "REPORT")) +(in-package "MONITOR") + +;;; Warn user if they're loading the source instead of compiling it first. +(eval-when (eval) + (warn "This file should be compiled before loading for best results.")) + +;;; ******************************** +;;; Version ************************ +;;; ******************************** + +(defparameter *metering-version* "v2.1 25-JAN-94" + "Current version number/date for Metering.") + + +;;; **************************************************************** +;;; Implementation Dependent Definitions *************************** +;;; **************************************************************** + +;;; ******************************** +;;; Timing Functions *************** +;;; ******************************** +;;; The get-time function is called to find the total number of ticks since +;;; the beginning of time. time-units-per-second allows us to convert units +;;; to seconds. + +#-(or clisp openmcl) +(eval-when (compile eval) + (warn + "You may want to supply implementation-specific get-time functions.")) + +(defconstant time-units-per-second internal-time-units-per-second) + +(defmacro get-time () + `(the time-type (get-internal-run-time))) + +;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of +;;; milliseconds spent during GC. We could subtract this from +;;; the value returned by get-internal-run-time to eliminate +;;; the effect of GC on the timing values, but we prefer to let +;;; the user run without GC on. If the application is so big that +;;; it requires GC to complete, then the GC times are part of the +;;; cost of doing business, and will average out in the long run. +;;; If it seems really important to a user that GC times not be +;;; counted, then uncomment the following three lines and read-time +;;; conditionalize the definition of get-time above with #-:openmcl. +;#+openmcl +;(defmacro get-time () +; `(the time-type (- (get-internal-run-time) (ccl:gctime)))) + +;;; ******************************** +;;; Consing Functions ************** +;;; ******************************** +;;; The get-cons macro is called to find the total number of bytes +;;; consed since the beginning of time. + +#+clisp +(defun get-cons () + (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount) + (sys::%%time) + (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount)) + (dpb space1 (byte 24 24) space2))) + +;;; Macintosh Common Lisp 2.0 +;;; Note that this includes bytes that were allocated during GC. +;;; We could subtract this out by advising GC like we did under +;;; MCL 1.3.2, but I'd rather users ran without GC. If they can't +;;; run without GC, then the bytes consed during GC are a cost of +;;; running their program. Metering the code a few times will +;;; avoid the consing values being too lopsided. If a user really really +;;; wants to subtract out the consing during GC, replace the following +;;; two lines with the commented out code. +#+openmcl +(defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated))) +;; #+openmcl +;; (progn +;; (in-package :ccl) +;; (defvar *bytes-consed-chkpt* 0) +;; (defun reset-consing () (setq *bytes-consed-chkpt* 0)) +;; (let ((old-gc (symbol-function 'gc)) +;; (ccl:*warn-if-redefine-kernel* nil)) +;; (setf (symbol-function 'gc) +;; #'(lambda () +;; (let ((old-consing (total-bytes-consed))) +;; (prog1 +;; (funcall old-gc) +;; (incf *bytes-consed-chkpt* +;; (- old-consing (total-bytes-consed)))))))) +;; (defun total-bytes-consed () +;; "Returns number of conses (8 bytes each)" +;; (ccl::total-bytes-allocated)) +;; (in-package "MONITOR") +;; (defun get-cons () +;; (the consing-type (+ (ccl::total-bytes-consed) ccl::*bytes-consed-chkpt*)))) + + +#-(or clisp openmcl) +(progn + (eval-when (compile eval) + (warn "No consing will be reported unless a get-cons function is ~ + defined.")) + + (defmacro get-cons () '(the consing-type 0))) + +;; actually, neither `get-cons' nor `get-time' are used as is, +;; but only in the following macro `with-time/cons' +#-:clisp +(defmacro with-time/cons ((delta-time delta-cons) form &body post-process) + (let ((start-cons (gensym "START-CONS-")) + (start-time (gensym "START-TIME-"))) + `(let ((,start-time (get-time)) (,start-cons (get-cons))) + (declare (type time-type ,start-time) + (type consing-type ,start-cons)) + (multiple-value-prog1 ,form + (let ((,delta-time (- (get-time) ,start-time)) + (,delta-cons (- (get-cons) ,start-cons))) + ,@post-process))))) + +#+clisp +(progn + (defmacro delta4 (nv1 nv2 ov1 ov2 by) + `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2)) + + (let ((del (find-symbol "DELTA4" "SYS"))) + (when del (setf (fdefinition 'delta4) (fdefinition del)))) + + (if (< internal-time-units-per-second 1000000) + ;; TIME_1: AMIGA, OS/2, UNIX_TIMES + (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) + `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16)) + ;; TIME_2: other UNIX, WIN32 + (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) + `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second) + (- ,new-time2 ,old-time2)))) + + (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2) + `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24)) + + ;; avoid consing: when the application conses a lot, + ;; get-cons may return a bignum, so we really should not use it. + (defmacro with-time/cons ((delta-time delta-cons) form &body post-process) + (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-")) + (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-")) + (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-")) + (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-")) + (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym))) + `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2 + ,gc1 ,gc2 ,beg-cons1 ,beg-cons2) (sys::%%time) + (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) + (multiple-value-prog1 ,form + (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2 + ,gc1 ,gc2 ,end-cons1 ,end-cons2) (sys::%%time) + (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) + (let ((,delta-time (delta4-time ,end-time1 ,end-time2 + ,beg-time1 ,beg-time2)) + (,delta-cons (delta4-cons ,end-cons1 ,end-cons2 + ,beg-cons1 ,beg-cons2))) + ,@post-process))))))) + +;;; ******************************** +;;; Required Arguments ************* +;;; ******************************** +;;; +;;; Required (Fixed) vs Optional Args +;;; +;;; To avoid unnecessary consing in the "encapsulation" code, we find out the +;;; number of required arguments, and use &rest to capture only non-required +;;; arguments. The function Required-Arguments returns two values: the first +;;; is the number of required arguments, and the second is T iff there are any +;;; non-required arguments (e.g. &optional, &rest, &key). + +;;; Lucid, Allegro, and Macintosh Common Lisp +#+openmcl +(defun required-arguments (name) + (let* ((function (symbol-function name)) + (args (ccl:arglist function)) + (pos (position-if #'(lambda (x) + (and (symbolp x) + (let ((name (symbol-name x))) + (and (>= (length name) 1) + (char= (schar name 0) + #\&))))) + args))) + (if pos + (values pos t) + (values (length args) nil)))) + +#+clisp +(defun required-arguments (name) + (multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p) + (sys::function-signature name t) + (if name ; no error + (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p)) + (values 0 t)))) + +#-(or clisp openmcl) +(progn + (eval-when (compile eval) + (warn + "You may want to add an implementation-specific Required-Arguments function.")) + (eval-when (load eval) + (defun required-arguments (name) + (declare (ignore name)) + (values 0 t)))) + +#| +;;;Examples +(defun square (x) (* x x)) +(defun square2 (x &optional y) (* x x y)) +(defun test (x y &optional (z 3)) 3) +(defun test2 (x y &optional (z 3) &rest fred) 3) + +(required-arguments 'square) => 1 nil +(required-arguments 'square2) => 1 t +(required-arguments 'test) => 2 t +(required-arguments 'test2) => 2 t +|# + + +;;; **************************************************************** +;;; Main METERING Code ********************************************* +;;; **************************************************************** + +;;; ******************************** +;;; Global Variables *************** +;;; ******************************** +(defvar *MONITOR-TIME-OVERHEAD* nil + "The amount of time an empty monitored function costs.") +(defvar *MONITOR-CONS-OVERHEAD* nil + "The amount of cons an empty monitored function costs.") + +(defvar *TOTAL-TIME* 0 + "Total amount of time monitored so far.") +(defvar *TOTAL-CONS* 0 + "Total amount of consing monitored so far.") +(defvar *TOTAL-CALLS* 0 + "Total number of calls monitored so far.") +(proclaim '(type time-type *total-time*)) +(proclaim '(type consing-type *total-cons*)) +(proclaim '(fixnum *total-calls*)) + +;;; ******************************** +;;; Accessor Functions ************* +;;; ******************************** +;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables +;;; containing closures. +(defmacro PLACE-FUNCTION (function-place) + "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE +if it isn't a symbol, to allow monitoring of closures located in +variables/arrays/structures." + ;; Note that (fboundp 'fdefinition) returns T even if fdefinition + ;; is a macro, which is what we want. + (if (fboundp 'fdefinition) + `(if (fboundp ,function-place) + (fdefinition ,function-place) + (eval ,function-place)) + `(if (symbolp ,function-place) + (symbol-function ,function-place) + (eval ,function-place)))) + +(defsetf PLACE-FUNCTION (function-place) (function) + "Set the function in FUNCTION-PLACE to FUNCTION." + (if (fboundp 'fdefinition) + ;; If we're conforming to CLtL2, use fdefinition here. + `(if (fboundp ,function-place) + (setf (fdefinition ,function-place) ,function) + (eval '(setf ,function-place ',function))) + `(if (symbolp ,function-place) + (setf (symbol-function ,function-place) ,function) + (eval '(setf ,function-place ',function))))) + +#| +;;; before using fdefinition +(defun PLACE-FUNCTION (function-place) + "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE +if it isn't a symbol, to allow monitoring of closures located in +variables/arrays/structures." + (if (symbolp function-place) + (symbol-function function-place) + (eval function-place))) + +(defsetf PLACE-FUNCTION (function-place) (function) + "Set the function in FUNCTION-PLACE to FUNCTION." + `(if (symbolp ,function-place) + (setf (symbol-function ,function-place) ,function) + (eval '(setf ,function-place ',function)))) +|# + +(defun PLACE-FBOUNDP (function-place) + "Test to see if FUNCTION-PLACE is a function." + ;; probably should be + #|(or (and (symbolp function-place)(fboundp function-place)) + (functionp (place-function function-place)))|# + (if (symbolp function-place) + (fboundp function-place) + (functionp (place-function function-place)))) + +(defun PLACE-MACROP (function-place) + "Test to see if FUNCTION-PLACE is a macro." + (when (symbolp function-place) + (macro-function function-place))) + +;;; ******************************** +;;; Measurement Tables ************* +;;; ******************************** +(defvar *monitored-functions* nil + "List of monitored symbols.") + +;;; We associate a METERING-FUNCTIONS structure with each monitored function +;;; name or other closure. This holds the functions that we call to manipulate +;;; the closure which implements the encapsulation. +;;; +(defstruct metering-functions + (name nil) + (old-definition nil :type function) + (new-definition nil :type function) + (read-metering nil :type function) + (reset-metering nil :type function)) + +;;; In general using hash tables in time-critical programs is a bad idea, +;;; because when one has to grow the table and rehash everything, the +;;; timing becomes grossly inaccurate. In this case it is not an issue +;;; because all inserting of entries in the hash table occurs before the +;;; timing commences. The only circumstance in which this could be a +;;; problem is if the lisp rehashes on the next reference to the table, +;;; instead of when the entry which forces a rehash was inserted. +;;; +;;; Note that a similar kind of problem can occur with GC, which is why +;;; one should turn off GC when monitoring code. +;;; +(defvar *monitor* (make-hash-table :test #'equal) + "Hash table in which METERING-FUNCTIONS structures are stored.") +(defun get-monitor-info (name) + (gethash name *monitor*)) +(defsetf get-monitor-info (name) (info) + `(setf (gethash ,name *monitor*) ,info)) + +(defun MONITORED (function-place) + "Test to see if a FUNCTION-PLACE is monitored." + (and (place-fboundp function-place) ; this line necessary? + (get-monitor-info function-place))) + +(defun reset-monitoring-info (name) + "Reset the monitoring info for the specified function." + (let ((finfo (get-monitor-info name))) + (when finfo + (funcall (metering-functions-reset-metering finfo))))) +(defun reset-all-monitoring () + "Reset monitoring info for all functions." + (setq *total-time* 0 + *total-cons* 0 + *total-calls* 0) + (dolist (symbol *monitored-functions*) + (when (monitored symbol) + (reset-monitoring-info symbol)))) + +(defun monitor-info-values (name &optional (nested :exclusive) warn) + "Returns monitoring information values for the named function, +adjusted for overhead." + (let ((finfo (get-monitor-info name))) + (if finfo + (multiple-value-bind (inclusive-time inclusive-cons + exclusive-time exclusive-cons + calls nested-calls) + (funcall (metering-functions-read-metering finfo)) + (unless (or (null warn) + (eq (place-function name) + (metering-functions-new-definition finfo))) + (warn "Funtion ~S has been redefined, so times may be inaccurate.~@ + MONITOR it again to record calls to the new definition." + name)) + (case nested + (:exclusive (values calls + nested-calls + (- exclusive-time + (* calls *monitor-time-overhead*)) + (- exclusive-cons + (* calls *monitor-cons-overhead*)))) + ;; In :inclusive mode, subtract overhead for all the + ;; called functions as well. Nested-calls includes the + ;; calls of the function as well. [Necessary 'cause of + ;; functions which call themselves recursively.] + (:inclusive (values calls + nested-calls + (- inclusive-time + (* nested-calls ;(+ calls) + *monitor-time-overhead*)) + (- inclusive-cons + (* nested-calls ;(+ calls) + *monitor-cons-overhead*)))))) + (values 0 0 0 0)))) + +;;; ******************************** +;;; Encapsulate ******************** +;;; ******************************** +(eval-when (compile load eval) +;; Returns a lambda expression for a function that, when called with the +;; function name, will set up that function for metering. +;; +;; A function is monitored by replacing its definition with a closure +;; created by the following function. The closure records the monitoring +;; data, and updates the data with each call of the function. +;; +;; Other closures are used to read and reset the data. +(defun make-monitoring-encapsulation (min-args optionals-p) + (let (required-args) + (dotimes (i min-args) (push (gensym) required-args)) + `(lambda (name) + (let ((inclusive-time 0) + (inclusive-cons 0) + (exclusive-time 0) + (exclusive-cons 0) + (calls 0) + (nested-calls 0) + (old-definition (place-function name))) + (declare (type time-type inclusive-time) + (type time-type exclusive-time) + (type consing-type inclusive-cons) + (type consing-type exclusive-cons) + (fixnum calls) + (fixnum nested-calls)) + (pushnew name *monitored-functions*) + + (setf (place-function name) + #'(lambda (,@required-args + ,@(when optionals-p + `(&rest optional-args))) + (let ((prev-total-time *total-time*) + (prev-total-cons *total-cons*) + (prev-total-calls *total-calls*) + ;; (old-time inclusive-time) + ;; (old-cons inclusive-cons) + ;; (old-nested-calls nested-calls) + ) + (declare (type time-type prev-total-time) + (type consing-type prev-total-cons) + (fixnum prev-total-calls)) + (with-time/cons (delta-time delta-cons) + ;; form + ,(if optionals-p + `(apply old-definition + ,@required-args optional-args) + `(funcall old-definition ,@required-args)) + ;; post-processing: + ;; Calls + (incf calls) + (incf *total-calls*) + ;; nested-calls includes this call + (incf nested-calls (the fixnum + (- *total-calls* + prev-total-calls))) + ;; (setf nested-calls (+ old-nested-calls + ;; (- *total-calls* + ;; prev-total-calls))) + ;; Time + ;; Problem with inclusive time is that it + ;; currently doesn't add values from recursive + ;; calls to the same function. Change the + ;; setf to an incf to fix this? + (incf inclusive-time (the time-type delta-time)) + ;; (setf inclusive-time (+ delta-time old-time)) + (incf exclusive-time (the time-type + (+ delta-time + (- prev-total-time + *total-time*)))) + (setf *total-time* (the time-type + (+ delta-time + prev-total-time))) + ;; Consing + (incf inclusive-cons (the consing-type delta-cons)) + ;; (setf inclusive-cons (+ delta-cons old-cons)) + (incf exclusive-cons (the consing-type + (+ delta-cons + (- prev-total-cons + *total-cons*)))) + (setf *total-cons* + (the consing-type + (+ delta-cons prev-total-cons))))))) + (setf (get-monitor-info name) + (make-metering-functions + :name name + :old-definition old-definition + :new-definition (place-function name) + :read-metering #'(lambda () + (values inclusive-time + inclusive-cons + exclusive-time + exclusive-cons + calls + nested-calls)) + :reset-metering #'(lambda () + (setq inclusive-time 0 + inclusive-cons 0 + exclusive-time 0 + exclusive-cons 0 + calls 0 + nested-calls 0) + t))))))) +);; End of EVAL-WHEN + +;;; For efficiency reasons, we precompute the encapsulation functions +;;; for a variety of combinations of argument structures +;;; (min-args . optional-p). These are stored in the following hash table +;;; along with any new ones we encounter. Since we're now precomputing +;;; closure functions for common argument signatures, this eliminates +;;; the former need to call COMPILE for each monitored function. +(eval-when (compile eval) + (defconstant precomputed-encapsulations 8)) + +(defvar *existing-encapsulations* (make-hash-table :test #'equal)) +(defun find-encapsulation (min-args optionals-p) + (or (gethash (cons min-args optionals-p) *existing-encapsulations*) + (setf (gethash (cons min-args optionals-p) *existing-encapsulations*) + (compile nil + (make-monitoring-encapsulation min-args optionals-p))))) + +(macrolet ((frob () + (let ((res ())) + (dotimes (i precomputed-encapsulations) + (push `(setf (gethash '(,i . nil) *existing-encapsulations*) + #',(make-monitoring-encapsulation i nil)) + res) + (push `(setf (gethash '(,i . t) *existing-encapsulations*) + #',(make-monitoring-encapsulation i t)) + res)) + `(progn ,@res)))) + (frob)) + +(defun monitoring-encapsulate (name &optional warn) + "Monitor the function Name. If already monitored, unmonitor first." + ;; Saves the current definition of name and inserts a new function which + ;; returns the result of evaluating body. + (cond ((not (place-fboundp name)) ; not a function + (when warn + (warn "Ignoring undefined function ~S." name))) + ((place-macrop name) ; a macro + (when warn + (warn "Ignoring macro ~S." name))) + (t ; tis a function + (when (get-monitor-info name) ; monitored + (when warn + (warn "~S already monitored, so unmonitoring it first." name)) + (monitoring-unencapsulate name)) + (multiple-value-bind (min-args optionals-p) + (required-arguments name) + (funcall (find-encapsulation min-args optionals-p) name))))) + +(defun monitoring-unencapsulate (name &optional warn) + "Removes monitoring encapsulation code from around Name." + (let ((finfo (get-monitor-info name))) + (when finfo ; monitored + (remprop name 'metering-functions) + (setq *monitored-functions* + (remove name *monitored-functions* :test #'equal)) + (if (eq (place-function name) + (metering-functions-new-definition finfo)) + (setf (place-function name) + (metering-functions-old-definition finfo)) + (when warn + (warn "Preserving current definition of redefined function ~S." + name)))))) + +;;; ******************************** +;;; Main Monitoring Functions ****** +;;; ******************************** +(defmacro MONITOR (&rest names) + "Monitor the named functions. As in TRACE, the names are not evaluated. + If a function is already monitored, then unmonitor and remonitor (useful + to notice function redefinition). If a name is undefined, give a warning + and ignore it. See also unmonitor, report-monitoring, + display-monitoring-results and reset-time." + `(progn + ,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names) + *monitored-functions*)) + +(defmacro UNMONITOR (&rest names) + "Remove the monitoring on the named functions. + Names defaults to the list of all currently monitored functions." + `(dolist (name ,(if names `',names '*monitored-functions*) (values)) + (monitoring-unencapsulate name))) + +(defun MONITOR-ALL (&optional (package *package*)) + "Monitor all functions in the specified package." + (let ((package (if (packagep package) + package + (find-package package)))) + (do-symbols (symbol package) + (when (eq (symbol-package symbol) package) + (monitoring-encapsulate symbol))))) + +(defmacro MONITOR-FORM (form + &optional (nested :exclusive) (threshold 0.01) + (key :percent-time)) + "Monitor the execution of all functions in the current package +during the execution of FORM. All functions that are executed above +THRESHOLD % will be reported." + `(unwind-protect + (progn + (monitor-all) + (reset-all-monitoring) + (prog1 + (time ,form) + (report-monitoring :all ,nested ,threshold ,key :ignore-no-calls))) + (unmonitor))) + +(defmacro WITH-MONITORING ((&rest functions) + (&optional (nested :exclusive) + (threshold 0.01) + (key :percent-time)) + &body body) + "Monitor the specified functions during the execution of the body." + `(unwind-protect + (progn + (dolist (fun ',functions) + (monitoring-encapsulate fun)) + (reset-all-monitoring) + ,@body + (report-monitoring :all ,nested ,threshold ,key)) + (unmonitor))) + +;;; ******************************** +;;; Overhead Calculations ********** +;;; ******************************** +(defconstant overhead-iterations 5000 + "Number of iterations over which the timing overhead is averaged.") + +;;; Perhaps this should return something to frustrate clever compilers. +(defun STUB-FUNCTION (x) + (declare (ignore x)) + nil) +(proclaim '(notinline stub-function)) + +(defun SET-MONITOR-OVERHEAD () + "Determines the average overhead of monitoring by monitoring the execution +of an empty function many times." + (setq *monitor-time-overhead* 0 + *monitor-cons-overhead* 0) + (stub-function nil) + (monitor stub-function) + (reset-all-monitoring) + (let ((overhead-function (symbol-function 'stub-function))) + (dotimes (x overhead-iterations) + (funcall overhead-function overhead-function))) +; (dotimes (x overhead-iterations) +; (stub-function nil)) + (let ((fiter (float overhead-iterations))) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values 'stub-function) + (declare (ignore calls nested-calls)) + (setq *monitor-time-overhead* (/ time fiter) + *monitor-cons-overhead* (/ cons fiter)))) + (unmonitor stub-function)) +(set-monitor-overhead) + +;;; ******************************** +;;; Report Data ******************** +;;; ******************************** +(defvar *monitor-results* nil + "A table of monitoring statistics is stored here.") +(defvar *no-calls* nil + "A list of monitored functions which weren't called.") +(defvar *estimated-total-overhead* 0) +;; (proclaim '(type time-type *estimated-total-overhead*)) + +(defstruct (monitoring-info + (:conc-name m-info-) + (:constructor make-monitoring-info + (name calls time cons + percent-time percent-cons + time-per-call cons-per-call))) + name + calls + time + cons + percent-time + percent-cons + time-per-call + cons-per-call) + +(defun REPORT (&key (names :all) + (nested :exclusive) + (threshold 0.01) + (sort-key :percent-time) + (ignore-no-calls nil)) + "Same as REPORT-MONITORING but with a nicer keyword interface" + (declare (type (member :function :percent-time :time :percent-cons + :cons :calls :time-per-call :cons-per-call) + sort-key) + (type (member :inclusive :exclusive) nested)) + (report-monitoring names nested threshold sort-key ignore-no-calls)) + +(defun REPORT-MONITORING (&optional names + (nested :exclusive) + (threshold 0.01) + (key :percent-time) + ignore-no-calls) + "Report the current monitoring state. +The percentage of the total time spent executing unmonitored code +in each function (:exclusive mode), or total time (:inclusive mode) +will be printed together with the number of calls and +the unmonitored time per call. Functions that have been executed +below THRESHOLD % of the time will not be reported. To report on all +functions set NAMES to be either NIL or :ALL." + (when (or (null names) (eq names :all)) (setq names *monitored-functions*)) + + (let ((total-time 0) + (total-cons 0) + (total-calls 0)) + ;; Compute overall time and consing. + (dolist (name names) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values name nested :warn) + (declare (ignore nested-calls)) + (incf total-calls calls) + (incf total-time time) + (incf total-cons cons))) + ;; Total overhead. + (setq *estimated-total-overhead* + (/ (* *monitor-time-overhead* total-calls) + time-units-per-second)) + ;; Assemble data for only the specified names (all monitored functions) + (if (zerop total-time) + (format *trace-output* "Not enough execution time to monitor.") + (progn + (setq *monitor-results* nil *no-calls* nil) + (dolist (name names) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values name nested) + (declare (ignore nested-calls)) + (when (minusp time) (setq time 0.0)) + (when (minusp cons) (setq cons 0.0)) + (if (zerop calls) + (push (if (symbolp name) + (symbol-name name) + (format nil "~S" name)) + *no-calls*) + (push (make-monitoring-info + (format nil "~S" name) ; name + calls ; calls + (/ time (float time-units-per-second)) ; time in secs + (round cons) ; consing + (/ time (float total-time)) ; percent-time + (if (zerop total-cons) 0 + (/ cons (float total-cons))) ; percent-cons + (/ (/ time (float calls)) ; time-per-call + time-units-per-second) ; sec/call + (round (/ cons (float calls)))) ; cons-per-call + *monitor-results*)))) + (display-monitoring-results threshold key ignore-no-calls))))) + +(defun display-monitoring-results (&optional (threshold 0.01) (key :percent-time) + (ignore-no-calls t)) + (let ((max-length 8) ; Function header size + (max-cons-length 8) + (total-time 0.0) + (total-consed 0) + (total-calls 0) + (total-percent-time 0) + (total-percent-cons 0)) + (sort-results key) + (dolist (result *monitor-results*) + (when (or (zerop threshold) + (> (m-info-percent-time result) threshold)) + (setq max-length + (max max-length + (length (m-info-name result)))) + (setq max-cons-length + (max max-cons-length + (m-info-cons-per-call result))))) + (incf max-length 2) + (setf max-cons-length (+ 2 (ceiling (log max-cons-length 10)))) + (format *trace-output* + "~%~%~ + ~VT ~VA~ + ~% ~VT % % ~VA Total Total~ + ~%Function~VT Time Cons Calls Sec/Call ~VA Time Cons~ + ~%~V,,,'-A" + max-length + max-cons-length "Cons" + max-length + max-cons-length "Per" + max-length + max-cons-length "Call" + (+ max-length 62 (max 0 (- max-cons-length 5))) "-") + (dolist (result *monitor-results*) + (when (or (zerop threshold) + (> (m-info-percent-time result) threshold)) + (format *trace-output* + "~%~A:~VT~6,2F ~6,2F ~7D ~,6F ~VD ~8,3F ~10D" + (m-info-name result) + max-length + (* 100 (m-info-percent-time result)) + (* 100 (m-info-percent-cons result)) + (m-info-calls result) + (m-info-time-per-call result) + max-cons-length + (m-info-cons-per-call result) + (m-info-time result) + (m-info-cons result)) + (incf total-time (m-info-time result)) + (incf total-consed (m-info-cons result)) + (incf total-calls (m-info-calls result)) + (incf total-percent-time (m-info-percent-time result)) + (incf total-percent-cons (m-info-percent-cons result)))) + (format *trace-output* + "~%~V,,,'-A~ + ~%TOTAL:~VT~6,2F ~6,2F ~7D ~9@T ~VA ~8,3F ~10D~ + ~%Estimated monitoring overhead: ~5,2F seconds~ + ~%Estimated total monitoring overhead: ~5,2F seconds" + (+ max-length 62 (max 0 (- max-cons-length 5))) "-" + max-length + (* 100 total-percent-time) + (* 100 total-percent-cons) + total-calls + max-cons-length " " + total-time total-consed + (/ (* *monitor-time-overhead* total-calls) + time-units-per-second) + *estimated-total-overhead*) + (when (and (not ignore-no-calls) *no-calls*) + (setq *no-calls* (sort *no-calls* #'string<)) + (let ((num-no-calls (length *no-calls*))) + (if (> num-no-calls 20) + (format *trace-output* + "~%~@(~r~) monitored functions were not called. ~ + ~%See the variable mon::*no-calls* for a list." + num-no-calls) + (format *trace-output* + "~%The following monitored functions were not called:~ + ~%~{~<~%~:; ~A~>~}~%" + *no-calls*)))) + (values))) + +(defun sort-results (&optional (key :percent-time)) + (setq *monitor-results* + (case key + (:function (sort *monitor-results* #'string> + :key #'m-info-name)) + ((:percent-time :time) (sort *monitor-results* #'> + :key #'m-info-time)) + ((:percent-cons :cons) (sort *monitor-results* #'> + :key #'m-info-cons)) + (:calls (sort *monitor-results* #'> + :key #'m-info-calls)) + (:time-per-call (sort *monitor-results* #'> + :key #'m-info-time-per-call)) + (:cons-per-call (sort *monitor-results* #'> + :key #'m-info-cons-per-call))))) + +;;; *END OF FILE* + + Added: branches/trunk-reorg/thirdparty/slime/mkdist.sh =================================================================== --- branches/trunk-reorg/thirdparty/slime/mkdist.sh 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/mkdist.sh 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,17 @@ +#!/bin/sh + +# This code has been placed in the Public Domain. All warranties +# are disclaimed. + +version="1.2" +dist="slime-$version" + +if [ -d $dist ]; then rm -rf $dist; fi + +mkdir $dist +cp NEWS README HACKING PROBLEMS ChangeLog *.el *.lisp $dist/ + +mkdir $dist/doc +cp doc/Makefile doc/slime.texi doc/texinfo-tabulate.awk $dist/doc + +tar czf $dist.tar.gz $dist Property changes on: branches/trunk-reorg/thirdparty/slime/mkdist.sh ___________________________________________________________________ Name: svn:executable + * Added: branches/trunk-reorg/thirdparty/slime/nregex.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/nregex.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/nregex.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,523 @@ +;;; +;;; This code was written by: +;;; +;;; Lawrence E. Freil <lef(a)freil.com> +;;; National Science Center Foundation +;;; Augusta, Georgia 30909 +;;; +;;; This program was released into the public domain on 2005-08-31. +;;; (See the slime-devel mailing list archive for details.) +;;; +;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression +;;; parser. +;;; +;;; This regular expression parser operates by taking a +;;; regular expression and breaking it down into a list +;;; consisting of lisp expressions and flags. The list +;;; of lisp expressions is then taken in turned into a +;;; lambda expression that can be later applied to a +;;; string argument for parsing. +;;;; +;;;; Modifications made 6 March 2001 By Chris Double (chris(a)double.co.nz) +;;;; to get working with Corman Lisp 1.42, add package statement and export +;;;; relevant functions. +;;;; + +(in-package :cl-user) + +;; Renamed to slime-nregex avoid name clashes with other versions of +;; this file. -- he + +;;;; CND - 6/3/2001 +(defpackage slime-nregex + (:use #:common-lisp) + (:export + #:regex + #:regex-compile + )) + +;;;; CND - 6/3/2001 +(in-package :slime-nregex) + +;;; +;;; First we create a copy of macros to help debug the beast +(eval-when (:compile-toplevel :load-toplevel :execute) +(defvar *regex-debug* nil) ; Set to nil for no debugging code +) + +(defmacro info (message &rest args) + (if *regex-debug* + `(format *standard-output* ,message ,@args))) + +;;; +;;; Declare the global variables for storing the paren index list. +;;; +(defvar *regex-groups* (make-array 10)) +(defvar *regex-groupings* 0) + +;;; +;;; Declare a simple interface for testing. You probably wouldn't want +;;; to use this interface unless you were just calling this once. +;;; +(defun regex (expression string) + "Usage: (regex <expression> <string) + This function will call regex-compile on the expression and then apply + the string to the returned lambda list." + (let ((findit (cond ((stringp expression) + (regex-compile expression)) + ((listp expression) + expression))) + (result nil)) + (if (not (funcall (if (functionp findit) + findit + (eval `(function ,findit))) string)) + (return-from regex nil)) + (if (= *regex-groupings* 0) + (return-from regex t)) + (dotimes (i *regex-groupings*) + (push (funcall 'subseq + string + (car (aref *regex-groups* i)) + (cadr (aref *regex-groups* i))) + result)) + (reverse result))) + +;;; +;;; Declare some simple macros to make the code more readable. +;;; +(defvar *regex-special-chars* "?*+.()[]\\${}") + +(defmacro add-exp (list) + "Add an item to the end of expression" + `(setf expression (append expression ,list))) + +;;; +;;; Define a function that will take a quoted character and return +;;; what the real character should be plus how much of the source +;;; string was used. If the result is a set of characters, return an +;;; array of bits indicating which characters should be set. If the +;;; expression is one of the sub-group matches return a +;;; list-expression that will provide the match. +;;; +(defun regex-quoted (char-string &optional (invert nil)) + "Usage: (regex-quoted <char-string> &optional invert) + Returns either the quoted character or a simple bit vector of bits set for + the matching values" + (let ((first (char char-string 0)) + (result (char char-string 0)) + (used-length 1)) + (cond ((eql first #\n) + (setf result #\NewLine)) + ((eql first #\c) + (setf result #\Return)) + ((eql first #\t) + (setf result #\Tab)) + ((eql first #\d) + (setf result #*0000000000000000000000000000000000000000000000001111111111000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\D) + (setf result #*1111111111111111111111111111111111111111111111110000000000111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\w) + (setf result #*0000000000000000000000000000000000000000000000001111111111000000011111111111111111111111111000010111111111111111111111111110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\W) + (setf result #*1111111111111111111111111111111111111111111111110000000000111111100000000000000000000000000111101000000000000000000000000001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\b) + (setf result #*0000000001000000000000000000000011000000000010100000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\B) + (setf result #*1111111110111111111111111111111100111111111101011111111111011111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\s) + (setf result #*0000000001100000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\S) + (setf result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((and (>= (char-code first) (char-code #\0)) + (<= (char-code first) (char-code #\9))) + (if (and (> (length char-string) 2) + (and (>= (char-code (char char-string 1)) (char-code #\0)) + (<= (char-code (char char-string 1)) (char-code #\9)) + (>= (char-code (char char-string 2)) (char-code #\0)) + (<= (char-code (char char-string 2)) (char-code #\9)))) + ;; + ;; It is a single character specified in octal + ;; + (progn + (setf result (do ((x 0 (1+ x)) + (return 0)) + ((= x 2) return) + (setf return (+ (* return 8) + (- (char-code (char char-string x)) + (char-code #\0)))))) + (setf used-length 3)) + ;; + ;; We have a group number replacement. + ;; + (let ((group (- (char-code first) (char-code #\0)))) + (setf result `((let ((nstring (subseq string (car (aref *regex-groups* ,group)) + (cadr (aref *regex-groups* ,group))))) + (if (< length (+ index (length nstring))) + (return-from compare nil)) + (if (not (string= string nstring + :start1 index + :end1 (+ index (length nstring)))) + (return-from compare nil) + (incf index (length nstring))))))))) + (t + (setf result first))) + (if (and (vectorp result) invert) + (bit-xor result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 t)) + (values result used-length))) + +;;; +;;; Now for the main regex compiler routine. +;;; +(defun regex-compile (source &key (anchored nil)) + "Usage: (regex-compile <expression> [ :anchored (t/nil) ]) + This function take a regular expression (supplied as source) and + compiles this into a lambda list that a string argument can then + be applied to. It is also possible to compile this lambda list + for better performance or to save it as a named function for later + use" + (info "Now entering regex-compile with \"~A\"~%" source) + ;; + ;; This routine works in two parts. + ;; The first pass take the regular expression and produces a list of + ;; operators and lisp expressions for the entire regular expression. + ;; The second pass takes this list and produces the lambda expression. + (let ((expression '()) ; holder for expressions + (group 1) ; Current group index + (group-stack nil) ; Stack of current group endings + (result nil) ; holder for built expression. + (fast-first nil)) ; holder for quick unanchored scan + ;; + ;; If the expression was an empty string then it alway + ;; matches (so lets leave early) + ;; + (if (= (length source) 0) + (return-from regex-compile + '(lambda (&rest args) + (declare (ignore args)) + t))) + ;; + ;; If the first character is a caret then set the anchored + ;; flags and remove if from the expression string. + ;; + (cond ((eql (char source 0) #\^) + (setf source (subseq source 1)) + (setf anchored t))) + ;; + ;; If the first sequence is .* then also set the anchored flags. + ;; (This is purely for optimization, it will work without this). + ;; + (if (>= (length source) 2) + (if (string= source ".*" :start1 0 :end1 2) + (setf anchored t))) + ;; + ;; Also, If this is not an anchored search and the first character is + ;; a literal, then do a quick scan to see if it is even in the string. + ;; If not then we can issue a quick nil, + ;; otherwise we can start the search at the matching character to skip + ;; the checks of the non-matching characters anyway. + ;; + ;; If I really wanted to speed up this section of code it would be + ;; easy to recognize the case of a fairly long multi-character literal + ;; and generate a Boyer-Moore search for the entire literal. + ;; + ;; I generate the code to do a loop because on CMU Lisp this is about + ;; twice as fast a calling position. + ;; + (if (and (not anchored) + (not (position (char source 0) *regex-special-chars*)) + (not (and (> (length source) 1) + (position (char source 1) *regex-special-chars*)))) + (setf fast-first `((if (not (dotimes (i length nil) + (if (eql (char string i) + ,(char source 0)) + (return (setf start i))))) + (return-from final-return nil))))) + ;; + ;; Generate the very first expression to save the starting index + ;; so that group 0 will be the entire string matched always + ;; + (add-exp '((setf (aref *regex-groups* 0) + (list index nil)))) + ;; + ;; Loop over each character in the regular expression building the + ;; expression list as we go. + ;; + (do ((eindex 0 (1+ eindex))) + ((= eindex (length source))) + (let ((current (char source eindex))) + (info "Now processing character ~A index = ~A~%" current eindex) + (case current + ((#\.) + ;; + ;; Generate code for a single wild character + ;; + (add-exp '((if (>= index length) + (return-from compare nil) + (incf index))))) + ((#\$) + ;; + ;; If this is the last character of the expression then + ;; anchor the end of the expression, otherwise let it slide + ;; as a standard character (even though it should be quoted). + ;; + (if (= eindex (1- (length source))) + (add-exp '((if (not (= index length)) + (return-from compare nil)))) + (add-exp '((if (not (and (< index length) + (eql (char string index) #\$))) + (return-from compare nil) + (incf index)))))) + ((#\*) + (add-exp '(ASTRISK))) + + ((#\+) + (add-exp '(PLUS))) + + ((#\?) + (add-exp '(QUESTION))) + + ((#$) + ;; + ;; Start a grouping. + ;; + (incf group) + (push group group-stack) + (add-exp `((setf (aref *regex-groups* ,(1- group)) + (list index nil)))) + (add-exp `(,group))) + ((#$) + ;; + ;; End a grouping + ;; + (let ((group (pop group-stack))) + (add-exp `((setf (cadr (aref *regex-groups* ,(1- group))) + index))) + (add-exp `(,(- group))))) + ((#\[) + ;; + ;; Start of a range operation. + ;; Generate a bit-vector that has one bit per possible character + ;; and then on each character or range, set the possible bits. + ;; + ;; If the first character is carat then invert the set. + (let* ((invert (eql (char source (1+ eindex)) #\^)) + (bitstring (make-array 256 :element-type 'bit + :initial-element + (if invert 1 0))) + (set-char (if invert 0 1))) + (if invert (incf eindex)) + (do ((x (1+ eindex) (1+ x))) + ((eql (char source x) #\]) (setf eindex x)) + (info "Building range with character ~A~%" (char source x)) + (cond ((and (eql (char source (1+ x)) #\-) + (not (eql (char source (+ x 2)) #\]))) + (if (>= (char-code (char source x)) + (char-code (char source (+ 2 x)))) + (error "Invalid range \"~A-~A\". Ranges must be in acending order" + (char source x) (char source (+ 2 x)))) + (do ((j (char-code (char source x)) (1+ j))) + ((> j (char-code (char source (+ 2 x)))) + (incf x 2)) + (info "Setting bit for char ~A code ~A~%" (code-char j) j) + (setf (sbit bitstring j) set-char))) + (t + (cond ((not (eql (char source x) #\])) + (let ((char (char source x))) + ;; + ;; If the character is quoted then find out what + ;; it should have been + ;; + (if (eql (char source x) #\\ ) + (let ((length)) + (multiple-value-setq (char length) + (regex-quoted (subseq source x) invert)) + (incf x length))) + (info "Setting bit for char ~A code ~A~%" char (char-code char)) + (if (not (vectorp char)) + (setf (sbit bitstring (char-code (char source x))) set-char) + (bit-ior bitstring char t)))))))) + (add-exp `((let ((range ,bitstring)) + (if (>= index length) + (return-from compare nil)) + (if (= 1 (sbit range (char-code (char string index)))) + (incf index) + (return-from compare nil))))))) + ((#\\ ) + ;; + ;; Intreprete the next character as a special, range, octal, group or + ;; just the character itself. + ;; + (let ((length) + (value)) + (multiple-value-setq (value length) + (regex-quoted (subseq source (1+ eindex)) nil)) + (cond ((listp value) + (add-exp value)) + ((characterp value) + (add-exp `((if (not (and (< index length) + (eql (char string index) + ,value))) + (return-from compare nil) + (incf index))))) + ((vectorp value) + (add-exp `((let ((range ,value)) + (if (>= index length) + (return-from compare nil)) + (if (= 1 (sbit range (char-code (char string index)))) + (incf index) + (return-from compare nil))))))) + (incf eindex length))) + (t + ;; + ;; We have a literal character. + ;; Scan to see how many we have and if it is more than one + ;; generate a string= verses as single eql. + ;; + (let* ((lit "") + (term (dotimes (litindex (- (length source) eindex) nil) + (let ((litchar (char source (+ eindex litindex)))) + (if (position litchar *regex-special-chars*) + (return litchar) + (progn + (info "Now adding ~A index ~A to lit~%" litchar + litindex) + (setf lit (concatenate 'string lit + (string litchar))))))))) + (if (= (length lit) 1) + (add-exp `((if (not (and (< index length) + (eql (char string index) ,current))) + (return-from compare nil) + (incf index)))) + ;; + ;; If we have a multi-character literal then we must + ;; check to see if the next character (if there is one) + ;; is an astrisk or a plus or a question mark. If so then we must not use this + ;; character in the big literal. + (progn + (if (or (eql term #\*) + (eql term #\+) + (eql term #\?)) + (setf lit (subseq lit 0 (1- (length lit))))) + (add-exp `((if (< length (+ index ,(length lit))) + (return-from compare nil)) + (if (not (string= string ,lit :start1 index + :end1 (+ index ,(length lit)))) + (return-from compare nil) + (incf index ,(length lit))))))) + (incf eindex (1- (length lit)))))))) + ;; + ;; Plug end of list to return t. If we made it this far then + ;; We have matched! + (add-exp '((setf (cadr (aref *regex-groups* 0)) + index))) + (add-exp '((return-from final-return t))) + ;; +;;; (print expression) + ;; + ;; Now take the expression list and turn it into a lambda expression + ;; replacing the special flags with lisp code. + ;; For example: A BEGIN needs to be replace by an expression that + ;; saves the current index, then evaluates everything till it gets to + ;; the END then save the new index if it didn't fail. + ;; On an ASTRISK I need to take the previous expression and wrap + ;; it in a do that will evaluate the expression till an error + ;; occurs and then another do that encompases the remainder of the + ;; regular expression and iterates decrementing the index by one + ;; of the matched expression sizes and then returns nil. After + ;; the last expression insert a form that does a return t so that + ;; if the entire nested sub-expression succeeds then the loop + ;; is broken manually. + ;; + (setf result (copy-tree nil)) + ;; + ;; Reversing the current expression makes building up the + ;; lambda list easier due to the nexting of expressions when + ;; and astrisk has been encountered. + (setf expression (reverse expression)) + (do ((elt 0 (1+ elt))) + ((>= elt (length expression))) + (let ((piece (nth elt expression))) + ;; + ;; Now check for PLUS, if so then ditto the expression and then let the + ;; ASTRISK below handle the rest. + ;; + (cond ((eql piece 'PLUS) + (cond ((listp (nth (1+ elt) expression)) + (setf result (append (list (nth (1+ elt) expression)) + result))) + ;; + ;; duplicate the entire group + ;; NOTE: This hasn't been implemented yet!! + (t + (error "GROUP repeat hasn't been implemented yet~%"))))) + (cond ((listp piece) ;Just append the list + (setf result (append (list piece) result))) + ((eql piece 'QUESTION) ; Wrap it in a block that won't fail + (cond ((listp (nth (1+ elt) expression)) + (setf result + (append `((progn (block compare + ,(nth (1+ elt) + expression)) + t)) + result)) + (incf elt)) + ;; + ;; This is a QUESTION on an entire group which + ;; hasn't been implemented yet!!! + ;; + (t + (error "Optional groups not implemented yet~%")))) + ((or (eql piece 'ASTRISK) ; Do the wild thing! + (eql piece 'PLUS)) + (cond ((listp (nth (1+ elt) expression)) + ;; + ;; This is a single character wild card so + ;; do the simple form. + ;; + (setf result + `((let ((oindex index)) + (block compare + (do () + (nil) + ,(nth (1+ elt) expression))) + (do ((start index (1- start))) + ((< start oindex) nil) + (let ((index start)) + (block compare + ,@result)))))) + (incf elt)) + (t + ;; + ;; This is a subgroup repeated so I must build + ;; the loop using several values. + ;; + )) + ) + (t t)))) ; Just ignore everything else. + ;; + ;; Now wrap the result in a lambda list that can then be + ;; invoked or compiled, however the user wishes. + ;; + (if anchored + (setf result + `(lambda (string &key (start 0) (end (length string))) + (setf *regex-groupings* ,group) + (block final-return + (block compare + (let ((index start) + (length end)) + ,@result))))) + (setf result + `(lambda (string &key (start 0) (end (length string))) + (setf *regex-groupings* ,group) + (block final-return + (let ((length end)) + ,@fast-first + (do ((marker start (1+ marker))) + ((> marker end) nil) + (let ((index marker)) + (if (block compare + ,@result) + (return t))))))))))) + +;; (provide 'nregex) Added: branches/trunk-reorg/thirdparty/slime/sbcl-pprint-patch.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/sbcl-pprint-patch.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/sbcl-pprint-patch.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,332 @@ +;; Pretty printer patch for SBCL, which adds the "annotations" feature +;; required for sending presentations through pretty-printing streams. +;; +;; The section marked "Changed functions" and the DEFSTRUCT +;; PRETTY-STREAM are based on SBCL's pprint.lisp. +;; +;; Public domain. + +(in-package "SB!PRETTY") + +(defstruct (annotation (:include queued-op)) + (handler (constantly nil) :type function) + (record)) + + +(defstruct (pretty-stream (:include sb!kernel:ansi-stream + (out #'pretty-out) + (sout #'pretty-sout) + (misc #'pretty-misc)) + (:constructor make-pretty-stream (target)) + (:copier nil)) + ;; Where the output is going to finally go. + (target (missing-arg) :type stream) + ;; Line length we should format to. Cached here so we don't have to keep + ;; extracting it from the target stream. + (line-length (or *print-right-margin* + (sb!impl::line-length target) + default-line-length) + :type column) + ;; A simple string holding all the text that has been output but not yet + ;; printed. + (buffer (make-string initial-buffer-size) :type (simple-array character (*))) + ;; The index into BUFFER where more text should be put. + (buffer-fill-pointer 0 :type index) + ;; Whenever we output stuff from the buffer, we shift the remaining noise + ;; over. This makes it difficult to keep references to locations in + ;; the buffer. Therefore, we have to keep track of the total amount of + ;; stuff that has been shifted out of the buffer. + (buffer-offset 0 :type posn) + ;; The column the first character in the buffer will appear in. Normally + ;; zero, but if we end up with a very long line with no breaks in it we + ;; might have to output part of it. Then this will no longer be zero. + (buffer-start-column (or (sb!impl::charpos target) 0) :type column) + ;; The line number we are currently on. Used for *PRINT-LINES* + ;; abbreviations and to tell when sections have been split across + ;; multiple lines. + (line-number 0 :type index) + ;; the value of *PRINT-LINES* captured at object creation time. We + ;; use this, instead of the dynamic *PRINT-LINES*, to avoid + ;; weirdness like + ;; (let ((*print-lines* 50)) + ;; (pprint-logical-block .. + ;; (dotimes (i 10) + ;; (let ((*print-lines* 8)) + ;; (print (aref possiblybigthings i) prettystream))))) + ;; terminating the output of the entire logical blockafter 8 lines. + (print-lines *print-lines* :type (or index null) :read-only t) + ;; Stack of logical blocks in effect at the buffer start. + (blocks (list (make-logical-block)) :type list) + ;; Buffer holding the per-line prefix active at the buffer start. + ;; Indentation is included in this. The length of this is stored + ;; in the logical block stack. + (prefix (make-string initial-buffer-size) :type (simple-array character (*))) + ;; Buffer holding the total remaining suffix active at the buffer start. + ;; The characters are right-justified in the buffer to make it easier + ;; to output the buffer. The length is stored in the logical block + ;; stack. + (suffix (make-string initial-buffer-size) :type (simple-array character (*))) + ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise, + ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest) + ;; cons. Adding things to the queue is basically (setf (cdr head) (list + ;; new)) and removing them is basically (pop tail) [except that care must + ;; be taken to handle the empty queue case correctly.] + (queue-tail nil :type list) + (queue-head nil :type list) + ;; Block-start queue entries in effect at the queue head. + (pending-blocks nil :type list) + ;; Queue of annotations to the buffer + (annotations-tail nil :type list) + (annotations-head nil :type list)) + + +(defmacro enqueue (stream type &rest args) + (let ((constructor (intern (concatenate 'string + "MAKE-" + (symbol-name type)) + "SB-PRETTY"))) + (once-only ((stream stream) + (entry `(,constructor :posn + (index-posn + (pretty-stream-buffer-fill-pointer + ,stream) + ,stream) + ,@args)) + (op `(list ,entry)) + (head `(pretty-stream-queue-head ,stream))) + `(progn + (if ,head + (setf (cdr ,head) ,op) + (setf (pretty-stream-queue-tail ,stream) ,op)) + (setf (pretty-stream-queue-head ,stream) ,op) + ,entry)))) + +;;; +;;; New helper functions +;;; + +(defun enqueue-annotation (stream handler record) + (enqueue stream annotation :handler handler + :record record)) + +(defun re-enqueue-annotation (stream annotation) + (let* ((annotation-cons (list annotation)) + (head (pretty-stream-annotations-head stream))) + (if head + (setf (cdr head) annotation-cons) + (setf (pretty-stream-annotations-tail stream) annotation-cons)) + (setf (pretty-stream-annotations-head stream) annotation-cons) + nil)) + +(defun re-enqueue-annotations (stream end) + (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail) + while (and tail (not (eql (car tail) end))) + when (annotation-p (car tail)) + do (re-enqueue-annotation stream (car tail)))) + +(defun dequeue-annotation (stream &key end-posn) + (let ((next-annotation (car (pretty-stream-annotations-tail stream)))) + (when next-annotation + (when (or (not end-posn) + (<= (annotation-posn next-annotation) end-posn)) + (pop (pretty-stream-annotations-tail stream)) + (unless (pretty-stream-annotations-tail stream) + (setf (pretty-stream-annotations-head stream) nil)) + next-annotation)))) + +(defun invoke-annotation (stream annotation truncatep) + (let ((target (pretty-stream-target stream))) + (funcall (annotation-handler annotation) + (annotation-record annotation) + target + truncatep))) + +(defun output-buffer-with-annotations (stream end) + (let ((target (pretty-stream-target stream)) + (buffer (pretty-stream-buffer stream)) + (end-posn (index-posn end stream)) + (start 0)) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do + (let ((annotation-index (posn-index (annotation-posn annotation) + stream))) + (when (> annotation-index start) + (write-string buffer target :start start + :end annotation-index) + (setf start annotation-index)) + (invoke-annotation stream annotation nil))) + (when (> end start) + (write-string buffer target :start start :end end)))) + +(defun flush-annotations (stream end truncatep) + (let ((end-posn (index-posn end stream))) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do (invoke-annotation stream annotation truncatep)))) + +;;; +;;; Changed functions +;;; + +(defun maybe-output (stream force-newlines-p) + (declare (type pretty-stream stream)) + (let ((tail (pretty-stream-queue-tail stream)) + (output-anything nil)) + (loop + (unless tail + (setf (pretty-stream-queue-head stream) nil) + (return)) + (let ((next (pop tail))) + (etypecase next + (newline + (when (ecase (newline-kind next) + ((:literal :mandatory :linear) t) + (:miser (misering-p stream)) + (:fill + (or (misering-p stream) + (> (pretty-stream-line-number stream) + (logical-block-section-start-line + (first (pretty-stream-blocks stream)))) + (ecase (fits-on-line-p stream + (newline-section-end next) + force-newlines-p) + ((t) nil) + ((nil) t) + (:dont-know + (return)))))) + (setf output-anything t) + (output-line stream next))) + (indentation + (unless (misering-p stream) + (set-indentation stream + (+ (ecase (indentation-kind next) + (:block + (logical-block-start-column + (car (pretty-stream-blocks stream)))) + (:current + (posn-column + (indentation-posn next) + stream))) + (indentation-amount next))))) + (block-start + (ecase (fits-on-line-p stream (block-start-section-end next) + force-newlines-p) + ((t) + ;; Just nuke the whole logical block and make it look like one + ;; nice long literal. (But don't nuke annotations.) + (let ((end (block-start-block-end next))) + (expand-tabs stream end) + (re-enqueue-annotations stream end) + (setf tail (cdr (member end tail))))) + ((nil) + (really-start-logical-block + stream + (posn-column (block-start-posn next) stream) + (block-start-prefix next) + (block-start-suffix next))) + (:dont-know + (return)))) + (block-end + (really-end-logical-block stream)) + (tab + (expand-tabs stream next)) + (annotation + (re-enqueue-annotation stream next)))) + (setf (pretty-stream-queue-tail stream) tail)) + output-anything)) + +(defun output-line (stream until) + (declare (type pretty-stream stream) + (type newline until)) + (let* ((target (pretty-stream-target stream)) + (buffer (pretty-stream-buffer stream)) + (kind (newline-kind until)) + (literal-p (eq kind :literal)) + (amount-to-consume (posn-index (newline-posn until) stream)) + (amount-to-print + (if literal-p + amount-to-consume + (let ((last-non-blank + (position #\space buffer :end amount-to-consume + :from-end t :test #'char/=))) + (if last-non-blank + (1+ last-non-blank) + 0))))) + (output-buffer-with-annotations stream amount-to-print) + (flush-annotations stream amount-to-consume nil) + (let ((line-number (pretty-stream-line-number stream))) + (incf line-number) + (when (and (not *print-readably*) + (pretty-stream-print-lines stream) + (>= line-number (pretty-stream-print-lines stream))) + (write-string " .." target) + (flush-annotations stream + (pretty-stream-buffer-fill-pointer stream) + t) + (let ((suffix-length (logical-block-suffix-length + (car (pretty-stream-blocks stream))))) + (unless (zerop suffix-length) + (let* ((suffix (pretty-stream-suffix stream)) + (len (length suffix))) + (write-string suffix target + :start (- len suffix-length) + :end len)))) + (throw 'line-limit-abbreviation-happened t)) + (setf (pretty-stream-line-number stream) line-number) + (write-char #\newline target) + (setf (pretty-stream-buffer-start-column stream) 0) + (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) + (block (first (pretty-stream-blocks stream))) + (prefix-len + (if literal-p + (logical-block-per-line-prefix-end block) + (logical-block-prefix-length block))) + (shift (- amount-to-consume prefix-len)) + (new-fill-ptr (- fill-ptr shift)) + (new-buffer buffer) + (buffer-length (length buffer))) + (when (> new-fill-ptr buffer-length) + (setf new-buffer + (make-string (max (* buffer-length 2) + (+ buffer-length + (floor (* (- new-fill-ptr buffer-length) + 5) + 4))))) + (setf (pretty-stream-buffer stream) new-buffer)) + (replace new-buffer buffer + :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr) + (replace new-buffer (pretty-stream-prefix stream) + :end1 prefix-len) + (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) + (incf (pretty-stream-buffer-offset stream) shift) + (unless literal-p + (setf (logical-block-section-column block) prefix-len) + (setf (logical-block-section-start-line block) line-number)))))) + +(defun output-partial-line (stream) + (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) + (tail (pretty-stream-queue-tail stream)) + (count + (if tail + (posn-index (queued-op-posn (car tail)) stream) + fill-ptr)) + (new-fill-ptr (- fill-ptr count)) + (buffer (pretty-stream-buffer stream))) + (when (zerop count) + (error "Output-partial-line called when nothing can be output.")) + (output-buffer-with-annotations stream count) + (incf (pretty-stream-buffer-start-column stream) count) + (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr) + (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) + (incf (pretty-stream-buffer-offset stream) count))) + +(defun force-pretty-output (stream) + (maybe-output stream nil) + (expand-tabs stream nil) + (re-enqueue-annotations stream nil) + (output-buffer-with-annotations stream + (pretty-stream-buffer-fill-pointer stream))) + \ No newline at end of file Added: branches/trunk-reorg/thirdparty/slime/slime-autoloads.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/slime-autoloads.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/slime-autoloads.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,50 @@ +;;; slime-autoloads.el --- autoload definitions for SLIME + +;; Copyright (C) 2007 Helmut Eller + +;; This file is protected by the GNU GPLv2 (or later), as distributed +;; with GNU Emacs. + +;;; Commentary: + +;; This code defines the necessary autoloads, so that we don't need to +;; load everything from .emacs. + +;;; Code: + +(autoload 'slime "slime" + "Start a Lisp subprocess and connect to its Swank server." t) + +(autoload 'slime-mode "slime" + "SLIME: The Superior Lisp Interaction (Minor) Mode for Emacs." t) + +(autoload 'slime-connect "slime" + "Connect to a running Swank server." t) + +(autoload 'hyperspec-lookup "hyperspec" nil t) + +(autoload 'slime-lisp-mode-hook "slime") +(autoload 'slime-scheme-mode-hook "slime") + +(defvar slime-lisp-modes '(lisp-mode)) + +(defun slime-setup (&optional contribs) + "Setup Emacs so that lisp-mode buffers always use SLIME. +CONTRIBS is a list of contrib packages to load." + (when (member 'lisp-mode slime-lisp-modes) + (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)) + (setq slime-setup-contribs contribs) + (add-hook 'slime-load-hook 'slime-setup-contribs)) + +(defvar slime-setup-contribs nil) + +(defun slime-setup-contribs () + (dolist (c slime-setup-contribs) + (require c) + (let ((init (intern (format "%s-init" c)))) + (when (fboundp init) + (funcall init))))) + +(provide 'slime-autoloads) + +;;; slime-autoloads.el ends here Added: branches/trunk-reorg/thirdparty/slime/slime.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/slime.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/slime.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,9543 @@ +;;; slime.el --- Superior Lisp Interaction Mode for Emacs +;; +;;;; License +;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller +;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of +;; the License, or (at your option) any later version. +;; +;; This program 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public +;; License along with this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;; MA 02111-1307, USA. + + +;;;; Commentary +;; +;; This file contains extensions for programming in Common Lisp. The +;; main features are: +;; +;; A socket-based communication/RPC interface between Emacs and +;; Lisp. +;; +;; The `slime-mode' minor-mode complementing `lisp-mode'. This new +;; mode includes many commands for interacting with the Common Lisp +;; process. +;; +;; Common Lisp REPL (Read-Eval-Print Loop) written in Emacs Lisp, +;; similar to `ielm'. +;; +;; Common Lisp debugger written in Emacs Lisp. The debugger pops up +;; an Emacs buffer similar to the Emacs/Elisp debugger. +;; +;; Trapping compiler messages and creating annotations in the source +;; file on the appropriate forms. +;; +;; SLIME is compatible with GNU Emacs 20 and 21 and XEmacs 21. In +;; order to run SLIME requires a supporting Lisp server called +;; Swank. Swank is distributed with slime.el and will automatically be +;; started in a normal installation. + + +;;;; Dependencies and setup + +(eval-and-compile + (require 'cl) + (unless (fboundp 'define-minor-mode) + (require 'easy-mmode) + (defalias 'define-minor-mode 'easy-mmode-define-minor-mode))) +(require 'comint) +(require 'timer) +(require 'pp) +(require 'hideshow) +(require 'hyperspec) +(require 'font-lock) +(when (featurep 'xemacs) + (require 'overlay)) +(require 'easymenu) + +(defvar slime-lisp-modes '(lisp-mode)) + +(defun slime-setup (&optional contribs) + "Setup Emacs so that lisp-mode buffers always use SLIME. +CONTRIBS is a list of contrib packages to load." + (when (member 'lisp-mode slime-lisp-modes) + (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)) + (dolist (c contribs) + (require c) + (let ((init (intern (format "%s-init" c)))) + (when (fboundp init) + (funcall init))))) + +(defun slime-lisp-mode-hook () + (slime-mode 1) + (set (make-local-variable 'lisp-indent-function) + 'common-lisp-indent-function)) + +(eval-and-compile + (defvar slime-path + (let ((path (or (locate-library "slime") load-file-name))) + (and path (file-name-directory path))) + "Directory containing the Slime package. +This is used to load the supporting Common Lisp library, Swank. +The default value is automatically computed from the location of the +Emacs Lisp package.")) + +(eval-and-compile + (defun slime-changelog-date () + "Return the datestring of the latest entry in the ChangeLog file. +Return nil if the ChangeLog file cannot be found." + (let ((changelog (concat slime-path "ChangeLog"))) + (if (file-exists-p changelog) + (with-temp-buffer + (insert-file-contents changelog nil 0 100) + (goto-char (point-min)) + (symbol-name (read (current-buffer)))) + nil)))) + +(defvar slime-protocol-version nil) +(setq slime-protocol-version + (eval-when-compile (slime-changelog-date))) + + +;;;; Customize groups +;; +;;;;; slime + +(defgroup slime nil + "Interaction with the Superior Lisp Environment." + :prefix "slime-" + :group 'applications) + +;;;;; slime-ui + +(defgroup slime-ui nil + "Interaction with the Superior Lisp Environment." + :prefix "slime-" + :group 'slime) + +(defcustom slime-truncate-lines t + "Set `truncate-lines' in popup buffers. +This applies to buffers that present lines as rows of data, such as +debugger backtraces and apropos listings." + :type 'boolean + :group 'slime-ui) + +(defcustom slime-update-modeline-package t + "Automatically update the Lisp package name in the minibuffer. +This is done with a text-search that runs on an idle timer." + :type 'boolean + :group 'slime-ui) + +(defcustom slime-kill-without-query-p nil + "If non-nil, kill SLIME processes without query when quitting Emacs. +This applies to the *inferior-lisp* buffer and the network connections." + :type 'boolean + :group 'slime-ui) + +;;;;; slime-lisp + +(defgroup slime-lisp nil + "Lisp server configuration." + :prefix "slime-" + :group 'slime) + +(defcustom slime-backend "swank-loader.lisp" + "The name of the Lisp file that loads the Swank server. +This name is interpreted relative to the directory containing +slime.el, but could also be set to an absolute filename." + :type 'string + :group 'slime-lisp) + +(defcustom slime-connected-hook nil + "List of functions to call when SLIME connects to Lisp." + :type 'hook + :group 'slime-lisp) + +(defcustom slime-filename-translations nil + "Assoc list of hostnames and filename translation functions. +Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP). + +HOSTNAME-REGEXP is a regexp which is applied to the connection's +slime-machine-instance. If HOSTNAME-REGEXP maches then the +corresponding TO-LISP and FROM-LISP functions will be used to +translate emacs filenames and lisp filenames. + +TO-LISP will be passed the filename of an emacs buffer and must +return a string which the underlying lisp understandas as a +pathname. FROM-LISP will be passed a pathname as returned by the +underlying lisp and must return something that emacs will +understand as a filename (this string will be passed to +find-file). + +This list will be traversed in order, so multiple matching +regexps are possible. + +Example: + +Assuming you run emacs locally and connect to slime running on +the machine 'soren' and you can connect with the username +'animaliter': + + (push (list \"^soren$\" + (lambda (emacs-filename) + (subseq emacs-filename (length \"/ssh:animaliter@soren:\"))) + (lambda (lisp-filename) + (concat \"/ssh:animaliter@soren:\" lisp-filename))) + slime-filename-translations) + +See also `slime-create-filename-translator'." + :type '(repeat (list :tag "Host description" + (regexp :tag "Hostname regexp") + (function :tag "To lisp function") + (function :tag "From lisp function"))) + :group 'slime-lisp) + +(defcustom slime-enable-evaluate-in-emacs nil + "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. +The default is nil, as this feature can be a security risk." + :type '(boolean) + :group 'slime-lisp) + +;;;;; slime-mode + +(defgroup slime-mode nil + "Settings for slime-mode Lisp source buffers." + :prefix "slime-" + :group 'slime) + +(defcustom slime-edit-definition-fallback-function nil + "Function to call when edit-definition fails to find the source itself. +The function is called with the definition name, a string, as its argument. + +If you want to fallback on TAGS you can set this to `find-tag', +`slime-find-tag-if-tags-table-visited', or +`slime-edit-definition-with-etags'." + :type 'symbol + :group 'slime-mode-mode + :options '(nil + slime-edit-definition-with-etags + slime-find-tag-if-tags-table-visited + find-tag)) + +(defcustom slime-complete-symbol-function 'slime-simple-complete-symbol + "*Function to perform symbol completion." + :group 'slime-mode + :type '(choice (const :tag "Simple" slime-simple-complete-symbol) + (const :tag "Compound" slime-complete-symbol*) + (const :tag "Fuzzy" slime-fuzzy-complete-symbol))) + +(defcustom slime-when-complete-filename-expand nil + "Use comint-replace-by-expanded-filename instead of comint-dynamic-complete-as-filename to complete file names" + :group 'slime-mode + :type 'boolean) + +(defcustom slime-space-information-p t + "Have the SPC key offer arglist information." + :type 'boolean + :group 'slime-mode) + +;;;;; slime-mode-faces + +(defgroup slime-mode-faces nil + "Faces in slime-mode source code buffers." + :prefix "slime-" + :group 'slime-mode) + +(defun slime-underline-color (color) + "Return a legal value for the :underline face attribute based on COLOR." + ;; In XEmacs the :underline attribute can only be a boolean. + ;; In GNU it can be the name of a colour. + (if (featurep 'xemacs) + (if color t nil) + color)) + +(defface slime-error-face + `((((class color) (background light)) + (:underline ,(slime-underline-color "red"))) + (((class color) (background dark)) + (:underline ,(slime-underline-color "red"))) + (t (:underline t))) + "Face for errors from the compiler." + :group 'slime-mode-faces) + +(defface slime-warning-face + `((((class color) (background light)) + (:underline ,(slime-underline-color "orange"))) + (((class color) (background dark)) + (:underline ,(slime-underline-color "coral"))) + (t (:underline t))) + "Face for warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-style-warning-face + `((((class color) (background light)) + (:underline ,(slime-underline-color "brown"))) + (((class color) (background dark)) + (:underline ,(slime-underline-color "gold"))) + (t (:underline t))) + "Face for style-warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-note-face + `((((class color) (background light)) + (:underline ,(slime-underline-color "brown4"))) + (((class color) (background dark)) + (:underline ,(slime-underline-color "light goldenrod"))) + (t (:underline t))) + "Face for notes from the compiler." + :group 'slime-mode-faces) + +(defun slime-face-inheritance-possible-p () + "Return true if the :inherit face attribute is supported." + (assq :inherit custom-face-attributes)) + +(defface slime-highlight-face + (if (slime-face-inheritance-possible-p) + '((t (:inherit highlight :underline nil))) + '((((class color) (background light)) + (:background "darkseagreen2")) + (((class color) (background dark)) + (:background "darkolivegreen")) + (t (:inverse-video t)))) + "Face for compiler notes while selected." + :group 'slime-mode-faces) + +;;;;; sldb + +(defgroup slime-debugger nil + "Backtrace options and fontification." + :prefix "sldb-" + :group 'slime) + +(defmacro define-sldb-faces (&rest faces) + "Define the set of SLDB faces. +Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES). +NAME is a symbol; the face will be called sldb-NAME-face. +DESCRIPTION is a one-liner for the customization buffer. +PROPERTIES specifies any default face properties." + `(progn ,@(loop for face in faces + collect `(define-sldb-face ,@face)))) + +(defmacro define-sldb-face (name description &optional default) + (let ((facename (intern (format "sldb-%s-face" (symbol-name name))))) + `(defface ,facename + (list (list t ,default)) + ,(format "Face for %s." description) + :group 'slime-debugger))) + +(define-sldb-faces + (topline "the top line describing the error") + (condition "the condition class") + (section "the labels of major sections in the debugger buffer") + (frame-label "backtrace frame numbers") + (restart-type "restart names." + (if (slime-face-inheritance-possible-p) + '(:inherit font-lock-keyword-face))) + (restart "restart descriptions") + (restart-number "restart numbers (correspond to keystrokes to invoke)" + '(:bold t)) + (frame-line "function names and arguments in the backtrace") + (detailed-frame-line + "function names and arguments in a detailed (expanded) frame") + (local-name "local variable names") + (local-value "local variable values") + (catch-tag "catch tags")) + +;;;;; slime-repl + +(defgroup slime-repl nil + "The Read-Eval-Print Loop (*slime-repl* buffer)." + :prefix "slime-repl-" + :group 'slime) + +(defcustom slime-repl-shortcut-dispatch-char ?\, + "Character used to distinguish repl commands from lisp forms." + :type '(character) + :group 'slime-repl) + +(defcustom slime-repl-only-save-lisp-buffers t + "When T we only attempt to save lisp-mode file buffers. When + NIL slime will attempt to save all buffers (as per + save-some-buffers). This applies to all ASDF related repl + shortcuts." + :type '(boolean) + :group 'slime-repl) + +(defcustom slime-repl-return-behaviour :send-if-complete + "Keyword specifying how slime-repl-return behaves when the + point is on a lisp expression (as opposed to being on a + previous output). + +Currently only two values are supported: + +:send-if-complete - If the current expression is complete, as per +slime-input-complete-p, it is sent to the underlying lisp, +otherwise a newline is inserted. The current value of (point) has +no effect. + +:send-only-if-after-complete - If the current expression is complete +and point is after the expression it is sent, otherwise a newline +is inserted." + :type '(choice (const :tag "Send if complete" :value :send-if-complete) + (const :tag "Send only if after complete" :value :send-only-if-after-complete)) + :group 'slime-repl) + + +(defface slime-repl-prompt-face + (if (slime-face-inheritance-possible-p) + '((t (:inherit font-lock-keyword-face))) + '((((class color) (background light)) (:foreground "Purple")) + (((class color) (background dark)) (:foreground "Cyan")) + (t (:weight bold)))) + "Face for the prompt in the SLIME REPL." + :group 'slime-repl) + +(defface slime-repl-output-face + (if (slime-face-inheritance-possible-p) + '((t (:inherit font-lock-string-face))) + '((((class color) (background light)) (:foreground "RosyBrown")) + (((class color) (background dark)) (:foreground "LightSalmon")) + (t (:slant italic)))) + "Face for Lisp output in the SLIME REPL." + :group 'slime-repl) + +(defface slime-repl-input-face + '((t (:bold t))) + "Face for previous input in the SLIME REPL." + :group 'slime-repl) + +(defface slime-repl-result-face + '((t ())) + "Face for the result of an evaluation in the SLIME REPL." + :group 'slime-repl) + +(defcustom slime-repl-history-file "~/.slime-history.eld" + "File to save the persistent REPL history to." + :type 'string + :group 'slime-repl) + +(defcustom slime-repl-history-size 200 + "*Maximum number of lines for persistent REPL history." + :type 'integer + :group 'slime-repl) + + +;;;; Minor modes + +;;;;; slime-mode + +(define-minor-mode slime-mode + "\\<slime-mode-map>\ +SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode). + +Commands to compile the current buffer's source file and visually +highlight any resulting compiler notes and warnings: +\\[slime-compile-and-load-file] - Compile and load the current buffer's file. +\\[slime-compile-file] - Compile (but not load) the current buffer's file. +\\[slime-compile-defun] - Compile the top-level form at point. + +Commands for visiting compiler notes: +\\[slime-next-note] - Goto the next form with a compiler note. +\\[slime-previous-note] - Goto the previous form with a compiler note. +\\[slime-remove-notes] - Remove compiler-note annotations in buffer. + +Finding definitions: +\\[slime-edit-definition] - Edit the definition of the function called at point. +\\[slime-pop-find-definition-stack] - Pop the definition stack to go back from a definition. + +Documentation commands: +\\[slime-describe-symbol] - Describe symbol. +\\[slime-apropos] - Apropos search. +\\[slime-disassemble-symbol] - Disassemble a function. + +Evaluation commands: +\\[slime-eval-defun] - Evaluate top-level from containing point. +\\[slime-eval-last-expression] - Evaluate sexp before point. +\\[slime-pprint-eval-last-expression] - Evaluate sexp before point, pretty-print result. + +Full set of commands: +\\{slime-mode-map}" + nil + nil + ;; Fake binding to coax `define-minor-mode' to create the keymap + '((" " 'undefined))) + +(make-variable-buffer-local + (defvar slime-modeline-package nil + "The Lisp package to show in the modeline. +This is automatically updated based on the buffer/point.")) + +(defun slime-update-modeline-package () + (ignore-errors + (when (and slime-update-modeline-package + (memq major-mode slime-lisp-modes) + slime-mode) + (let ((package (slime-current-package))) + (when package + (setq slime-modeline-package + (slime-pretty-package-name package))))))) + +(defun slime-pretty-package-name (name) + "Return a pretty version of a package name NAME." + (let ((name (cond ((string-match "^:\$.*\$$" name) + (match-string 1 name)) + ((string-match "^\"\$.*\$\"$" name) + (match-string 1 name)) + (t name)))) + (format "%s" (read name)))) + +(when slime-update-modeline-package + (run-with-idle-timer 0.2 0.2 'slime-update-modeline-package)) + +;; Setup the mode-line to say when we're in slime-mode, and which CL +;; package we think the current buffer belongs to. +(add-to-list 'minor-mode-alist + '(slime-mode + (" Slime" + ((slime-modeline-package (":" slime-modeline-package) "") + slime-state-name)))) + +(defun slime-input-complete-p (start end) + "Return t if the region from START to END contains a complete sexp." + (save-excursion + (goto-char start) + (cond ((looking-at "\\s *['`#]?[(\"]") + (ignore-errors + (save-restriction + (narrow-to-region start end) + ;; Keep stepping over blanks and sexps until the end of + ;; buffer is reached or an error occurs. Tolerate extra + ;; close parens. + (loop do (skip-chars-forward " \t\r\n)") + until (eobp) + do (forward-sexp)) + t))) + (t t)))) + + +;;;;; Key bindings + +;; See `slime-define-key' below for keyword meanings. +(defvar slime-keys + '(;; Compiler notes + ("\M-p" slime-previous-note) + ("\M-n" slime-next-note) + ("\M-c" slime-remove-notes :prefixed t) + ("\C-k" slime-compile-and-load-file :prefixed t) + ("\M-k" slime-compile-file :prefixed t) + ("\C-c" slime-compile-defun :prefixed t) + ("\C-l" slime-load-file :prefixed t) + ;; Editing/navigating + ("\M-\C-i" slime-complete-symbol :inferior t) + ("\C-i" slime-complete-symbol :prefixed t :inferior t) + ("\M-." slime-edit-definition :inferior t :sldb t) + ("\C-x4." slime-edit-definition-other-window :inferior t :sldb t) + ("\C-x5." slime-edit-definition-other-frame :inferior t :sldb t) + ("\M-," slime-pop-find-definition-stack :inferior t :sldb t) + ;; Evaluating + ("\C-x\C-e" slime-eval-last-expression :inferior t) + ("\C-x\M-e" slime-eval-last-expression-display-output :inferior t) + ("\C-p" slime-pprint-eval-last-expression :prefixed t :inferior t) + ("\C-r" slime-eval-region :prefixed t :inferior t) + ("\C-\M-x" slime-eval-defun) + (":" slime-interactive-eval :prefixed t :sldb t) + ("\C-e" slime-interactive-eval :prefixed t :sldb t :inferior t) + ("\C-y" slime-call-defun :prefixed t) + ("E" slime-edit-value :prefixed t :sldb t :inferior t) + ("\C-z" slime-switch-to-output-buffer :prefixed t :sldb t) + ("\C-b" slime-interrupt :prefixed t :inferior t :sldb t) + ("\M-g" slime-quit :prefixed t :inferior t :sldb t) + ;; Documentation + (" " slime-space :inferior t) + ("\C-f" slime-describe-function :prefixed t :inferior t :sldb t) + ("\M-d" slime-disassemble-symbol :prefixed t :inferior t :sldb t) + ("\C-t" slime-toggle-trace-fdefinition :prefixed t :sldb t) + ("\C-u" slime-undefine-function :prefixed t) + ("\C-m" slime-macroexpand-1 :prefixed t :inferior t) + ("\M-m" slime-macroexpand-all :prefixed t :inferior t) + ("\M-0" slime-restore-window-configuration :prefixed t :inferior t) + ([(control meta ?\.)] slime-next-location :inferior t) + ("~" slime-sync-package-and-default-directory :prefixed t :inferior t) + ("\M-p" slime-repl-set-package :prefixed t :inferior t) + ;; Cross reference + ("<" slime-list-callers :prefixed t :inferior t :sldb t) + (">" slime-list-callees :prefixed t :inferior t :sldb t) + ;; "Other" + ("\I" slime-inspect :prefixed t :inferior t :sldb t) + ("\C-]" slime-close-all-parens-in-sexp :prefixed t :inferior t :sldb t) + ("\C-xt" slime-list-threads :prefixed t :inferior t :sldb t) + ("\C-xc" slime-list-connections :prefixed t :inferior t :sldb t) + ;; ;; Shadow unwanted bindings from inf-lisp + ;; ("\C-a" slime-nop :prefixed t :inferior t :sldb t) + ;; ("\C-v" slime-nop :prefixed t :inferior t :sldb t) + )) + +(defun slime-nop () + "The null command. Used to shadow currently-unused keybindings." + (interactive) + (call-interactively 'undefined)) + +(defvar slime-doc-map (make-sparse-keymap) + "Keymap for documentation commands. Bound to a prefix key.") + +(defvar slime-doc-bindings + '((?a slime-apropos) + (?z slime-apropos-all) + (?p slime-apropos-package) + (?d slime-describe-symbol) + (?f slime-describe-function) + (?h slime-hyperspec-lookup) + (?~ common-lisp-hyperspec-format))) + +(defvar slime-who-map (make-sparse-keymap) + "Keymap for who-xref commands. Bound to a prefix key.") + +(defvar slime-who-bindings + '((?c slime-who-calls) + (?w slime-calls-who) + (?r slime-who-references) + (?b slime-who-binds) + (?s slime-who-sets) + (?m slime-who-macroexpands) + (?a slime-who-specializes))) + +;; Maybe a good idea, maybe not.. +(defvar slime-prefix-key "\C-c" + "The prefix key to use in SLIME keybinding sequences.") + +(defun* slime-define-key (key command &key prefixed inferior) + "Define a keybinding of KEY for COMMAND. +If PREFIXED is non-nil, `slime-prefix-key' is prepended to KEY." + (when prefixed + (setq key (concat slime-prefix-key key))) + (define-key slime-mode-map key command)) + +(defun slime-init-keymaps () + "(Re)initialize the keymaps for `slime-mode'." + (interactive) + (loop for (key command . keys) in slime-keys + do (apply #'slime-define-key key command :allow-other-keys t keys)) + ;; Documentation + (setq slime-doc-map (make-sparse-keymap)) + (loop for (key command) in slime-doc-bindings + do (progn + ;; We bind both unmodified and with control. + (define-key slime-doc-map (vector key) command) + (unless (equal key ?h) ; But don't bind C-h + (let ((modified (slime-control-modified-char key))) + (define-key slime-doc-map (vector modified) command))))) + ;; C-c C-d is the prefix for the doc map. + (slime-define-key "\C-d" slime-doc-map :prefixed t :inferior t) + ;; Who-xref + (setq slime-who-map (make-sparse-keymap)) + (loop for (key command) in slime-who-bindings + do (progn + ;; We bind both unmodified and with control. + (define-key slime-who-map (vector key) command) + (let ((modified (slime-control-modified-char key))) + (define-key slime-who-map (vector modified) command)))) + ;; C-c C-w is the prefix for the who-xref map. + (slime-define-key "\C-w" slime-who-map :prefixed t :inferior t)) + +(defun slime-control-modified-char (char) + "Return the control-modified version of CHAR." + ;; Maybe better to just bitmask it? + (read (format "?\\C-%c" char))) + +(slime-init-keymaps) + + +;;;; Setup initial `slime-mode' hooks + +(make-variable-buffer-local + (defvar slime-pre-command-actions nil + "List of functions to execute before the next Emacs command. +This list of flushed between commands.")) + +(defun slime-pre-command-hook () + "Execute all functions in `slime-pre-command-actions', then NIL it." + (dolist (undo-fn slime-pre-command-actions) + (ignore-errors (funcall undo-fn))) + (setq slime-pre-command-actions nil)) + +(defun slime-post-command-hook () + (when (null pre-command-hook) ; sometimes this is lost + (add-hook 'pre-command-hook 'slime-pre-command-hook))) + +(defun slime-setup-command-hooks () + "Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'." + (add-local-hook 'pre-command-hook 'slime-pre-command-hook) + (add-local-hook 'post-command-hook 'slime-post-command-hook)) + + +;;;; Framework'ey bits +;;; +;;; This section contains some standard SLIME idioms: basic macros, +;;; ways of showing messages to the user, etc. All the code in this +;;; file should use these functions when applicable. +;;; +;;;;; Syntactic sugar + +(defmacro* when-let ((var value) &rest body) + "Evaluate VALUE, and if the result is non-nil bind it to VAR and +evaluate BODY. + +\(fn (VAR VALUE) &rest BODY)" + `(let ((,var ,value)) + (when ,var ,@body))) + +(put 'when-let 'lisp-indent-function 1) + +(defmacro with-lexical-bindings (variables &rest body) + "Execute BODY with VARIABLES in lexical scope." + `(lexical-let ,(mapcar (lambda (variable) (list variable variable)) + variables) + ,@body)) + +(put 'with-lexical-bindings 'lisp-indent-function 1) + +(defmacro destructure-case (value &rest patterns) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (gensym "op-")) + (operands (gensym "rand-")) + (tmp (gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (case ,operator + ,@(mapcar (lambda (clause) + (if (eq (car clause) t) + `(t ,@(cdr clause)) + (destructuring-bind ((op &rest rands) &rest body) clause + `(,op (destructuring-bind ,rands ,operands + . ,body))))) + patterns) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "Elisp destructure-case failed: %S" ,tmp)))))))) + +(put 'destructure-case 'lisp-indent-function 1) + +(defmacro slime-define-keys (keymap &rest key-command) + "Define keys in KEYMAP. Each KEY-COMMAND is a list of (KEY COMMAND)." + `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c)) + key-command))) + +(put 'slime-define-keys 'lisp-indent-function 1) + +(defmacro* with-struct ((conc-name &rest slots) struct &body body) + "Like with-slots but works only for structs. +\(fn (CONC-NAME &rest SLOTS) STRUCT &body BODY)" + (flet ((reader (slot) (intern (concat (symbol-name conc-name) + (symbol-name slot))))) + (let ((struct-var (gensym "struct"))) + `(let ((,struct-var ,struct)) + (symbol-macrolet + ,(mapcar (lambda (slot) + (etypecase slot + (symbol `(,slot (,(reader slot) ,struct-var))) + (cons `(,(first slot) (,(reader (second slot)) + ,struct-var))))) + slots) + . ,body))))) + +(put 'with-struct 'lisp-indent-function 2) + +;;;;; Very-commonly-used functions + +(defvar slime-message-function 'message) + +;; Interface +(defun slime-message (format &rest args) + "Like `message' but with special support for multi-line messages. +Single-line messages use the echo area." + (apply slime-message-function format args)) + +(when (or (featurep 'xemacs) + (= emacs-major-version 20)) + (setq slime-message-function 'slime-format-display-message)) + +(defun slime-format-display-message (format &rest args) + (slime-display-message (apply #'format format args) "*SLIME Note*")) + +(defun slime-display-message (message buffer-name) + "Display MESSAGE in the echo area or in BUFFER-NAME. +Use the echo area if MESSAGE needs only a single line. If the MESSAGE +requires more than one line display it in BUFFER-NAME and add a hook +to `slime-pre-command-actions' to remove the window before the next +command." + (when (get-buffer-window buffer-name) (delete-windows-on buffer-name)) + (cond ((or (string-match "\n" message) + (> (length message) (1- (frame-width)))) + (lexical-let ((buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer + (erase-buffer) + (insert message) + (goto-char (point-min)) + (let ((win (slime-create-message-window))) + (set-window-buffer win (current-buffer)) + (shrink-window-if-larger-than-buffer + (display-buffer (current-buffer))))) + (push (lambda () (delete-windows-on buffer) (bury-buffer buffer)) + slime-pre-command-actions))) + (t (message "%s" message)))) + +(defun slime-create-message-window () + "Create a window at the bottom of the frame, above the minibuffer." + (let ((previous (previous-window (minibuffer-window)))) + (when (<= (window-height previous) (* 2 window-min-height)) + (save-selected-window + (select-window previous) + (enlarge-window (- (1+ (* 2 window-min-height)) + (window-height previous))))) + (split-window previous))) + +(defvar slime-background-message-function 'slime-display-oneliner) + +;; Interface +(defun slime-background-message (format-string &rest format-args) + "Display a message in passing. +This is like `slime-message', but less distracting because it +will never pop up a buffer or display multi-line messages. +It should be used for \"background\" messages such as argument lists." + (apply slime-background-message-function format-string format-args)) + +(defun slime-display-oneliner (format-string &rest format-args) + (let* ((msg (apply #'format format-string format-args))) + (unless (minibuffer-window-active-p (minibuffer-window)) + (message "%s" (slime-oneliner msg))))) + +(defun slime-oneliner (string) + "Return STRING truncated to fit in a single echo-area line." + (substring string 0 (min (length string) + (or (position ?\n string) most-positive-fixnum) + (1- (frame-width))))) + +;; Interface +(defun slime-set-truncate-lines () + "Apply `slime-truncate-lines' to the current buffer." + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +;; Interface +(defun slime-read-package-name (prompt &optional initial-value) + "Read a package name from the minibuffer, prompting with PROMPT." + (let ((completion-ignore-case t)) + (completing-read prompt (slime-bogus-completion-alist + (slime-eval + `(swank:list-all-package-names t))) + nil t initial-value))) + +;; Interface +(defun slime-read-symbol-name (prompt &optional query) + "Either read a symbol name or choose the one at point. +The user is prompted if a prefix argument is in effect, if there is no +symbol at point, or if QUERY is non-nil. + +This function avoids mistaking the REPL prompt for a symbol." + (cond ((or current-prefix-arg query (not (slime-symbol-name-at-point))) + (slime-read-from-minibuffer prompt (slime-symbol-name-at-point))) + (t (slime-symbol-name-at-point)))) + +;; Interface +(defmacro slime-propertize-region (props &rest body) + "Execute BODY and add PROPS to all the text it inserts. +More precisely, PROPS are added to the region between the point's +positions before and after executing BODY." + (let ((start (gensym))) + `(let ((,start (point))) + (prog1 (progn ,@body) + (add-text-properties ,start (point) ,props))))) + +(put 'slime-propertize-region 'lisp-indent-function 1) + +;; Interface +(defsubst slime-insert-propertized (props &rest args) + "Insert all ARGS and then add text-PROPS to the inserted text." + (slime-propertize-region props (apply #'insert args))) + +(defmacro slime-with-rigid-indentation (level &rest body) + "Execute BODY and then rigidly indent its text insertions. +Assumes all insertions are made at point." + (let ((start (gensym)) (l (gensym))) + `(let ((,start (point)) (,l ,(or level '(current-column)))) + (prog1 (progn ,@body) + (slime-indent-rigidly ,start (point) ,l))))) + +(put 'slime-with-rigid-indentation 'lisp-indent-function 1) + +(defun slime-indent-rigidly (start end column) + ;; Similar to `indent-rigidly' but doesn't inherit text props. + (save-excursion + (goto-char end) + (beginning-of-line) + (while (and (<= start (point)) + (progn + (save-excursion (insert-char ?\ column)) + (zerop (forward-line -1))))))) + +(defun slime-insert-indented (&rest strings) + "Insert all arguments rigidly indented." + (slime-with-rigid-indentation nil + (apply #'insert strings))) + +(defun slime-curry (fun &rest args) + `(lambda (&rest more) (apply ',fun (append ',args more)))) + +(defun slime-rcurry (fun &rest args) + `(lambda (&rest more) (apply ',fun (append more ',args)))) + +;;;;; Snapshots of current Emacs state + +;;; Window configurations do not save (and hence not restore) +;;; any narrowing that could be applied to a buffer. +;;; +;;; For this purpose, we introduce a superset of a window +;;; configuration that does include the necessary information to +;;; properly restore narrowing. +;;; +;;; We call this superset an Emacs Snapshot. + +(defstruct (slime-narrowing-configuration + (:conc-name slime-narrowing-configuration.)) + narrowedp beg end) + +(defstruct (slime-emacs-snapshot (:conc-name slime-emacs-snapshot.)) + window-configuration narrowing-configuration) + +(defun slime-current-narrowing-configuration (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (make-slime-narrowing-configuration :narrowedp (slime-buffer-narrowed-p) + :beg (point-min-marker) + :end (point-max-marker)))) + +(defun slime-set-narrowing-configuration (narrowing-cfg) + (when (slime-narrowing-configuration.narrowedp narrowing-cfg) + (narrow-to-region (slime-narrowing-configuration.beg narrowing-cfg) + (slime-narrowing-configuration.end narrowing-cfg)))) + +(defun slime-current-emacs-snapshot (&optional frame) + "Returns a snapshot of the current state of FRAME, or the +currently active frame if FRAME is not given respectively." + (with-current-buffer + (if frame + (window-buffer (frame-selected-window (selected-frame))) + (current-buffer)) + (make-slime-emacs-snapshot + :window-configuration (current-window-configuration frame) + :narrowing-configuration (slime-current-narrowing-configuration)))) + +(defun slime-set-emacs-snapshot (snapshot) + "Restores the state of Emacs according to the information saved +in SNAPSHOT." + (let ((window-cfg (slime-emacs-snapshot.window-configuration snapshot)) + (narrowing-cfg (slime-emacs-snapshot.narrowing-configuration snapshot))) + (set-window-configuration window-cfg) ; restores previously current buffer. + (slime-set-narrowing-configuration narrowing-cfg))) + +(defun slime-current-emacs-snapshot-fingerprint (&optional frame) + "Return a fingerprint of the current emacs snapshot. +Fingerprints are `equalp' if and only if they represent window +configurations that are very similar (same windows and buffers.) + +Unlike real window-configuration objects, fingerprints are not +sensitive to the point moving and they can't be restored." + (mapcar (lambda (window) (list window (window-buffer window))) + (slime-frame-windows frame))) + +(defun slime-frame-windows (&optional frame) + "Return the list of windows in FRAME." + (loop with last-window = (previous-window (frame-first-window frame)) + for window = (frame-first-window frame) then (next-window window) + collect window + until (eq window last-window))) + + +(defmacro save-restriction-if-possible (&rest body) + "Very similiarly to `save-restriction'. The only difference is +that it's not enforcing the restriction as strictly: It's only +enforced if `point' was not moved outside of the restriction +after executing BODY. + +Example: + + (progn (goto-line 1000) + (narrow-to-page) + (save-restriction-if-possible (widen) (goto-line 999))) + + In this case, the buffer is narrowed to the current page, and + point is on line 999. + + (progn (goto-char 1000) + (narrow-to-page) + (save-restriction-if-possible (widen) (goto-line 1))) + + Whereas in this case, the buffer is widened and point is on + line 1." + (let ((gcfg (gensym "NARROWING-CFG+")) + (gbeg (gensym "OLDBEG+")) + (gend (gensym "OLDEND+"))) + `(let ((,gcfg (slime-current-narrowing-configuration))) + (unwind-protect (progn ,@body) + (let ((,gbeg (slime-narrowing-configuration.beg ,gcfg)) + (,gend (slime-narrowing-configuration.end ,gcfg))) + (when (and (>= (point) ,gbeg) (<= (point) ,gend)) + (slime-set-narrowing-configuration ,gcfg))))))) + +(put 'save-restriction-if-possible 'lisp-indent-function 0) + +;;;;; Temporary popup buffers + +(make-variable-buffer-local + (defvar slime-temp-buffer-saved-emacs-snapshot nil + "The snapshot of the current state in Emacs before the temp-buffer +was displayed, so that this state can be restored later on. +Buffer local in temp-buffers.")) + +(make-variable-buffer-local + (defvar slime-temp-buffer-saved-fingerprint nil + "The emacs snapshot \"fingerprint\" after displaying the buffer.")) + +;; Interface +(defun* slime-get-temp-buffer-create (name &key mode noselectp reusep + emacs-snapshot) + "Return a fresh temporary buffer called NAME in MODE. +The buffer also uses the minor-mode `slime-temp-buffer-mode'. Pressing +`q' in the buffer will restore the window configuration to the way it +is when the buffer was created, i.e. when this function was called. + +If NOSELECTP is true, then the buffer is shown by `display-buffer', +otherwise it is shown and selected by `pop-to-buffer'. + +If REUSEP is true and a buffer does already exist with name NAME, +then the buffer will be reused instead of being killed. + +If EMACS-SNAPSHOT is non-NIL, it's used to restore the previous +state of Emacs after closing the temporary buffer. Otherwise, the +current state will be saved and later restored. +" + (let ((snapshot (or emacs-snapshot (slime-current-emacs-snapshot))) + (buffer (get-buffer name))) + (when (and buffer (not reusep)) + (kill-buffer name) + (setq buffer nil)) + (with-current-buffer (or buffer (get-buffer-create name)) + (when mode + (let ((original-configuration slime-temp-buffer-saved-emacs-snapshot) + (original-fingerprint slime-temp-buffer-saved-fingerprint)) + (funcall mode) + (setq slime-temp-buffer-saved-emacs-snapshot original-configuration) + (setq slime-temp-buffer-saved-fingerprint original-fingerprint))) + (slime-temp-buffer-mode 1) + (let ((window (get-buffer-window (current-buffer)))) + (if window + (unless noselectp + (select-window window)) + (progn + (if noselectp + (display-buffer (current-buffer) t) + (pop-to-buffer (current-buffer)) + (selected-window)) + (setq slime-temp-buffer-saved-emacs-snapshot snapshot) + (setq slime-temp-buffer-saved-fingerprint + (slime-current-emacs-snapshot-fingerprint))))) + (current-buffer)))) + +;; Interface +(defmacro* slime-with-output-to-temp-buffer ((name &key mode reusep) + package &rest body) + "Similar to `with-output-to-temp-buffer'. +Also saves the current state of Emacs (window configuration &c), +and inherits the current `slime-connection' in a buffer-local +variable. Cf. `slime-get-temp-buffer-create'" + `(let ((connection (slime-connection)) + (standard-output (slime-get-temp-buffer-create ,name :mode ',mode + :reusep ,reusep))) + (prog1 (with-current-buffer standard-output + ;; set explicitely to NIL in case the buffer got reused. (REUSEP) + (let ((buffer-read-only nil)) ,@body)) + (with-current-buffer standard-output + (setq slime-buffer-connection connection) + (setq slime-buffer-package ,package) + (goto-char (point-min)) + (slime-mode 1) + (set-syntax-table lisp-mode-syntax-table) + (setq buffer-read-only t))))) + +(put 'slime-with-output-to-temp-buffer 'lisp-indent-function 2) + +(define-minor-mode slime-temp-buffer-mode + "Mode for displaying read only stuff" + nil + " temp" + '(("q" . slime-temp-buffer-quit))) + +;; Interface +(defun slime-temp-buffer-quit (&optional kill-buffer-p) + "Get rid of the current (temp) buffer without asking. Restore the +window configuration unless it was changed since we last activated the buffer." + (interactive) + (let ((snapshot slime-temp-buffer-saved-emacs-snapshot) + (temp-buffer (current-buffer))) + (setq slime-temp-buffer-saved-emacs-snapshot nil) + (if (and snapshot (equalp (slime-current-emacs-snapshot-fingerprint) + slime-temp-buffer-saved-fingerprint)) + (slime-set-emacs-snapshot snapshot) + (bury-buffer)) + (when kill-buffer-p + (kill-buffer temp-buffer)))) + +;;;;; Filename translation +;;; +;;; Filenames passed between Emacs and Lisp should be translated using +;;; these functions. This way users who run Emacs and Lisp on separate +;;; machines have a chance to integrate file operations somehow. + +(defun slime-to-lisp-filename (filename) + "Translate the string FILENAME to a Lisp filename. +See `slime-filename-translations'." + (funcall (first (slime-find-filename-translators (slime-machine-instance))) + (expand-file-name filename))) + +(defun slime-from-lisp-filename (filename) + "Translate the Lisp filename FILENAME to an Emacs filename. +See `slime-filename-translations'." + (funcall (second (slime-find-filename-translators (slime-machine-instance))) + filename)) + +(defun slime-find-filename-translators (hostname) + (cond ((and hostname slime-filename-translations) + (or (cdr (assoc-if (lambda (regexp) (string-match regexp hostname)) + slime-filename-translations)) + (error "No filename-translations for hostname: %s" hostname))) + (t (list #'identity #'identity)))) + + +;;;; Starting SLIME +;;; +;;; This section covers starting an inferior-lisp, compiling and +;;; starting the server, initiating a network connection. + +;;;;; Entry points + +;; We no longer load inf-lisp, but we use this variable for backward +;; compatibility. +(defvar inferior-lisp-program "lisp" + "*Program name for invoking an inferior Lisp with for Inferior Lisp mode.") + +(defvar slime-lisp-implementations nil + "*A list of known Lisp implementations. +The list should have the form: + ((NAME (PROGRAM PROGRAM-ARGS...) &key INIT CODING-SYSTEM) ...) + +NAME is a symbol for the implementation. +PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process. +INIT is a function that should return a string to load and start + Swank. The function will be called with the PORT-FILENAME and ENCODING as + arguments. INIT defaults to `slime-init-command'. +CODING-SYSTEM a symbol for the coding system. The default is + slime-net-coding-system + +Here's an example: + ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init slime-init-command) + (acl (\"acl7\") :coding-system emacs-mule))") + +(defvar slime-default-lisp nil + "*The name of the default Lisp implementation. +See `slime-lisp-implementations'") + +(defvar slime-lisp-host "127.0.0.1" + "The default hostname (or IP address) to connect to.") + +;; dummy definitions for the compiler +(defvar slime-net-coding-system) +(defvar slime-net-processes) +(defvar slime-default-connection) + +(defun slime (&optional command coding-system) + "Start an inferior^_superior Lisp and connect to its Swank server." + (interactive) + (let ((inferior-lisp-program (or command inferior-lisp-program)) + (slime-net-coding-system (or coding-system slime-net-coding-system))) + (slime-start* (slime-read-interactive-args)))) + +(defvar slime-inferior-lisp-program-history '() + "History list of command strings. Used by `slime'.") + +(defun slime-read-interactive-args () + "Return the list of args which should be passed to `slime-start'. + +The rules for selecting the arguments are rather complicated: + +- In the most common case, i.e. if there's no prefix-arg in + effect and if `slime-lisp-implementations' is nil, use + `inferior-lisp-program' as fallback. + +- If the table `slime-lisp-implementations' is non-nil use the + implementation with name `slime-default-lisp' or if that's nil + the first entry in the table. + +- If the prefix-arg is `-', prompt for one of the registered + lisps. + +- If the prefix-arg is positive, read the command to start the + process." + (let ((table slime-lisp-implementations)) + (cond ((not current-prefix-arg) (slime-lisp-options)) + ((eq current-prefix-arg '-) + (let ((key (completing-read + "Lisp name: " (mapcar (lambda (x) + (list (symbol-name (car x)))) + table) + nil t))) + (slime-lookup-lisp-implementation table (intern key)))) + (t + (destructuring-bind (program &rest program-args) + (split-string (read-string + "Run lisp: " inferior-lisp-program + 'slime-inferior-lisp-program-history)) + (let ((coding-system + (if (eq 16 (prefix-numeric-value current-prefix-arg)) + (read-coding-system "set slime-coding-system: " + slime-net-coding-system) + slime-net-coding-system))) + (list :program program :program-args program-args + :coding-system coding-system))))))) + +(defun slime-lisp-options (&optional name) + (let ((table slime-lisp-implementations)) + (assert (or (not name) table)) + (cond (table (slime-lookup-lisp-implementation slime-lisp-implementations + (or name slime-default-lisp + (car (car table))))) + (t (destructuring-bind (program &rest args) + (split-string inferior-lisp-program) + (list :program program :program-args args)))))) + +(defun slime-lookup-lisp-implementation (table name) + (destructuring-bind (name (prog &rest args) &rest keys) (assoc name table) + (list* :name name :program prog :program-args args keys))) + +(defun* slime-start (&key (program inferior-lisp-program) program-args + directory + (coding-system slime-net-coding-system) + (init 'slime-init-command) + name + (buffer "*inferior-lisp*") + init-function) + (let ((args (list :program program :program-args program-args :buffer buffer + :coding-system coding-system :init init :name name + :init-function init-function))) + (slime-check-coding-system coding-system) + (when (slime-bytecode-stale-p) + (slime-urge-bytecode-recompile)) + (let ((proc (slime-maybe-start-lisp program program-args + directory buffer))) + (slime-inferior-connect proc args) + (pop-to-buffer (process-buffer proc))))) + +(defun slime-start* (options) + (apply #'slime-start options)) + +(defun slime-connect (host port &optional coding-system) + "Connect to a running Swank server." + (interactive (list (read-from-minibuffer "Host: " slime-lisp-host) + (read-from-minibuffer "Port: " "4005" nil t))) + (when (and (interactive-p) slime-net-processes + (y-or-n-p "Close old connections first? ")) + (slime-disconnect)) + (message "Connecting to Swank on port %S.." port) + (let ((coding-system (or coding-system slime-net-coding-system))) + (slime-check-coding-system coding-system) + (message "Connecting to Swank on port %S.." port) + (let* ((process (slime-net-connect host port coding-system)) + (slime-dispatching-connection process)) + (slime-setup-connection process)))) + +(defun slime-start-and-load (filename &optional package) + "Start Slime, if needed, load the current file and set the package." + (interactive (list (expand-file-name (buffer-file-name)) + (slime-find-buffer-package))) + (cond ((slime-connected-p) + (slime-load-file-set-package filename package)) + (t + (slime-start-and-init (slime-lisp-options) + (slime-curry #'slime-start-and-load + filename package))))) + +(defun slime-start-and-init (options fun) + (let* ((rest (plist-get options :init-function)) + (init (cond (rest `(lambda () (funcall ',rest) (funcall ',fun))) + (t fun)))) + (slime-start* (plist-put (copy-list options) :init-function init)))) + +(defun slime-load-file-set-package (filename package) + (let ((filename (slime-to-lisp-filename filename))) + (slime-eval-async `(swank:load-file-set-package ,filename ,package) + (lambda (package) + (when package + (slime-repl-set-package (second package))))))) + +;;;;; Start inferior lisp +;;; +;;; Here is the protocol for starting SLIME: +;;; +;;; 0. Emacs recompiles/reloads slime.elc if it exists and is stale. +;;; 1. Emacs starts an inferior Lisp process. +;;; 2. Emacs tells Lisp (via stdio) to load and start Swank. +;;; 3. Lisp recompiles the Swank if needed. +;;; 4. Lisp starts the Swank server and writes its TCP port to a temp file. +;;; 5. Emacs reads the temp file to get the port and then connects. +;;; 6. Emacs prints a message of warm encouragement for the hacking ahead. +;;; +;;; Between steps 2-5 Emacs polls for the creation of the temp file so +;;; that it can make the connection. This polling may continue for a +;;; fair while if Swank needs recompilation. + +(defvar slime-connect-retry-timer nil + "Timer object while waiting for an inferior-lisp to start.") + +;;; Recompiling bytecode: + +(defun slime-bytecode-stale-p () + "Return true if slime.elc is older than slime.el." + (when-let (libfile (locate-library "slime")) + (let* ((basename (file-name-sans-extension libfile)) + (sourcefile (concat basename ".el")) + (bytefile (concat basename ".elc"))) + (and (file-exists-p bytefile) + (file-newer-than-file-p sourcefile bytefile))))) + +(defun slime-recompile-bytecode () + "Recompile and reload slime. +Warning: don't use this in XEmacs, it seems to crash it!" + (interactive) + (let ((sourcefile (concat (file-name-sans-extension (locate-library "slime")) + ".el"))) + (byte-compile-file sourcefile t))) + +(defun slime-urge-bytecode-recompile () + "Urge the user to recompile slime.elc. +Return true if we have been given permission to continue." + (cond ((featurep 'xemacs) + ;; My XEmacs crashes and burns if I recompile/reload an elisp + ;; file from itself. So they have to do it themself. + (or (y-or-n-p "slime.elc is older than source. Continue? ") + (signal 'quit nil))) + ((y-or-n-p "slime.elc is older than source. Recompile first? ") + (slime-recompile-bytecode)) + (t))) + +(defun slime-abort-connection () + "Abort connection the current connection attempt." + (interactive) + (cond (slime-connect-retry-timer + (slime-cancel-connect-retry-timer) + (message "Cancelled connection attempt.")) + (t (error "Not connecting")))) + +;;; Starting the inferior Lisp and loading Swank: + +(defun slime-maybe-start-lisp (program program-args directory buffer) + "Return a new or existing inferior lisp process." + (cond ((not (comint-check-proc buffer)) + (slime-start-lisp program program-args directory buffer)) + ((slime-reinitialize-inferior-lisp-p program program-args buffer) + (when-let (conn (find (get-buffer-process buffer) slime-net-processes + :key #'slime-inferior-process)) + (slime-net-close conn)) + (get-buffer-process buffer)) + (t (slime-start-lisp program program-args + directory + (generate-new-buffer-name buffer))))) + +(defun slime-reinitialize-inferior-lisp-p (program program-args buffer) + (let ((args (slime-inferior-lisp-args (get-buffer-process buffer)))) + (and (equal (plist-get args :program) program) + (equal (plist-get args :program-args) program-args) + (not (y-or-n-p "Create an additional *inferior-lisp*? "))))) + +(defun slime-start-lisp (program program-args directory buffer) + "Does the same as `inferior-lisp' but less ugly. +Return the created process." + (with-current-buffer (get-buffer-create buffer) + (when directory + (cd (expand-file-name directory))) + (comint-mode) + (comint-exec (current-buffer) "inferior-lisp" program nil program-args) + (lisp-mode-variables t) + (let ((proc (get-buffer-process (current-buffer)))) + (slime-set-query-on-exit-flag proc) + proc))) + +(defun slime-inferior-connect (process args) + "Start a Swank server in the inferior Lisp and connect." + (slime-delete-swank-port-file 'quiet) + (slime-start-swank-server process args) + (slime-read-port-and-connect process nil)) + +(defvar slime-inferior-lisp-args nil + "A buffer local variable in the inferior proccess.") + +(defun slime-start-swank-server (process args) + "Start a Swank server on the inferior lisp." + (destructuring-bind (&key coding-system init &allow-other-keys) args + (with-current-buffer (process-buffer process) + (make-local-variable 'slime-inferior-lisp-args) + (setq slime-inferior-lisp-args args) + (let ((str (funcall init (slime-swank-port-file) coding-system))) + (goto-char (process-mark process)) + (insert-before-markers str) + (process-send-string process str))))) + +(defun slime-inferior-lisp-args (process) + (with-current-buffer (process-buffer process) + slime-inferior-lisp-args)) + +;; XXX load-server & start-server used to be separated. maybe that was better. +(defun slime-init-command (port-filename coding-system) + "Return a string to initialize Lisp." + (let ((loader (if (file-name-absolute-p slime-backend) + slime-backend + (concat slime-path slime-backend))) + (encoding (slime-coding-system-cl-name coding-system))) + ;; Return a single form to avoid problems with buffered input. + (format "%S\n\n" + `(progn + (load ,(expand-file-name loader) :verbose t) + (funcall (read-from-string "swank:start-server") + ,port-filename + :coding-system ,encoding))))) + +(defun slime-swank-port-file () + "Filename where the SWANK server writes its TCP port number." + (concat (file-name-as-directory + (cond ((fboundp 'temp-directory) (temp-directory)) + ((boundp 'temporary-file-directory) temporary-file-directory) + (t "/tmp/"))) + (format "slime.%S" (emacs-pid)))) + +(defun slime-delete-swank-port-file (&optional quiet) + (condition-case data + (delete-file (slime-swank-port-file)) + (error + (ecase quiet + ((nil) (signal (car data) (cdr data))) + (quiet) + (message (message "Unable to delete swank port file %S" + (slime-swank-port-file))))))) + +(defun slime-read-port-and-connect (inferior-process retries) + (slime-cancel-connect-retry-timer) + (slime-attempt-connection inferior-process retries 1)) + +(defun slime-attempt-connection (process retries attempt) + ;; A small one-state machine to attempt a connection with + ;; timer-based retries. + (let ((file (slime-swank-port-file))) + (unless (active-minibuffer-window) + (message "Polling %S.. (Abort with `M-x slime-abort-connection'.)" file)) + (unless (slime-connected-p) + (slime-set-state (format "[polling:%S]" attempt))) + (slime-cancel-connect-retry-timer) + (cond ((and (file-exists-p file) + (> (nth 7 (file-attributes file)) 0)) ; file size + (let ((port (slime-read-swank-port)) + (args (slime-inferior-lisp-args process))) + (slime-delete-swank-port-file 'message) + (let ((c (slime-connect slime-lisp-host port + (plist-get args :coding-system)))) + (slime-set-inferior-process c process)))) + ((and retries (zerop retries)) + (message "Failed to connect to Swank.")) + (t + (when (and (file-exists-p file) + (zerop (nth 7 (file-attributes file)))) + (message "(Zero length port file)") + ;; the file may be in the filesystem but not yet written + (unless retries (setq retries 3))) + (setq slime-connect-retry-timer + (run-with-timer 0.3 nil + #'slime-timer-call #'slime-attempt-connection + process (and retries (1- retries)) + (1+ attempt))))))) + +(defun slime-timer-call (fun &rest args) + "Call function FUN with ARGS, reporting all errors. + +The default condition handler for timer functions (see +`timer-event-handler') ignores errors." + (condition-case data + (apply fun args) + (error (debug nil (list "Error in timer" fun args data))))) + +(defun slime-cancel-connect-retry-timer () + (when slime-connect-retry-timer + (cancel-timer slime-connect-retry-timer) + (setq slime-connect-retry-timer nil))) + +(defun slime-read-swank-port () + "Read the Swank server port number from the `slime-swank-port-file'." + (save-excursion + (with-temp-buffer + (insert-file-contents (slime-swank-port-file)) + (goto-char (point-min)) + (let ((port (read (current-buffer)))) + (assert (integerp port)) + port)))) + +(defun slime-hide-inferior-lisp-buffer () + "Display the REPL buffer instead of the *inferior-lisp* buffer." + (let* ((buffer (if (slime-process) + (process-buffer (slime-process)))) + (window (if buffer (get-buffer-window buffer))) + (repl-buffer (slime-output-buffer t)) + (repl-window (get-buffer-window repl-buffer))) + (when buffer + (bury-buffer buffer)) + (cond (repl-window + (when window + (delete-window window))) + (window + (set-window-buffer window repl-buffer)) + (t + (pop-to-buffer repl-buffer) + (goto-char (point-max)))))) + +;;; Words of encouragement + +(defun slime-user-first-name () + (let ((name (if (string= (user-full-name) "") + (user-login-name) + (user-full-name)))) + (string-match "^[^ ]*" name) + (capitalize (match-string 0 name)))) + +(defvar slime-words-of-encouragement + `("Let the hacking commence!" + "Hacks and glory await!" + "Hack and be merry!" + "Your hacking starts... NOW!" + "May the source be with you!" + "Take this REPL, brother, and may it serve you well." + "Lemonodor-fame is but a hack away!" + ,(format "%s, this could be the start of a beautiful program." + (slime-user-first-name))) + "Scientifically-proven optimal words of hackerish encouragement.") + +(defun slime-random-words-of-encouragement () + "Return a string of hackerish encouragement." + (eval (nth (random (length slime-words-of-encouragement)) + slime-words-of-encouragement))) + + +;;;; Networking +;;; +;;; This section covers the low-level networking: establishing +;;; connections and encoding/decoding protocol messages. +;;; +;;; Each SLIME protocol message beings with a 3-byte length header +;;; followed by an S-expression as text. The sexp must be readable +;;; both by Emacs and by Common Lisp, so if it contains any embedded +;;; code fragments they should be sent as strings. +;;; +;;; The set of meaningful protocol messages are not specified +;;; here. They are defined elsewhere by the event-dispatching +;;; functions in this file and in swank.lisp. + +(defvar slime-net-processes nil + "List of processes (sockets) connected to Lisps.") + +(defvar slime-net-process-close-hooks '() + "List of functions called when a slime network connection closes. +The functions are called with the process as their argument.") + +(defun slime-secret () + "Finds the magic secret from the user's home directory. +Returns nil if the file doesn't exist or is empty; otherwise the first +line of the file." + (condition-case err + (with-temp-buffer + (insert-file-contents "~/.slime-secret") + (goto-char (point-min)) + (buffer-substring (point-min) (line-end-position))) + (file-error nil))) + +;;; Interface +(defun slime-net-connect (host port coding-system) + "Establish a connection with a CL." + (let* ((inhibit-quit nil) + (proc (open-network-stream "SLIME Lisp" nil host port)) + (buffer (slime-make-net-buffer " *cl-connection*"))) + (push proc slime-net-processes) + (set-process-buffer proc buffer) + (set-process-filter proc 'slime-net-filter) + (set-process-sentinel proc 'slime-net-sentinel) + (slime-set-query-on-exit-flag proc) + (when (fboundp 'set-process-coding-system) + (slime-check-coding-system coding-system) + (set-process-coding-system proc coding-system coding-system)) + (when-let (secret (slime-secret)) + (slime-net-send secret proc)) + proc)) + +(defun slime-make-net-buffer (name) + "Make a buffer suitable for a network process." + (let ((buffer (generate-new-buffer name))) + (with-current-buffer buffer + (buffer-disable-undo)) + buffer)) + +(defun slime-set-query-on-exit-flag (process) + "Set PROCESS's query-on-exit-flag to `slime-kill-without-query-p'." + (when slime-kill-without-query-p + ;; avoid byte-compiler warnings + (let ((fun (if (fboundp 'set-process-query-on-exit-flag) + 'set-process-query-on-exit-flag + 'process-kill-without-query))) + (funcall fun process nil)))) + +;;;;; Coding system madness + +(defvar slime-net-valid-coding-systems + '((iso-latin-1-unix nil "iso-latin-1-unix") + (iso-8859-1-unix nil "iso-latin-1-unix") + (binary nil "iso-latin-1-unix") + (utf-8-unix t "utf-8-unix") + (emacs-mule-unix t "emacs-mule-unix") + (euc-jp-unix t "euc-jp-unix")) + "A list of valid coding systems. +Each element is of the form: (NAME MULTIBYTEP CL-NAME)") + +(defun slime-find-coding-system (name) + "Return the coding system for the symbol NAME. +The result is either an element in `slime-net-valid-coding-systems' +of nil." + (let* ((probe (assq name slime-net-valid-coding-systems))) + (if (and probe (if (fboundp 'check-coding-system) + (ignore-errors (check-coding-system (car probe))) + (eq (car probe) 'binary))) + probe))) + +(defvar slime-net-coding-system + (find-if 'slime-find-coding-system + '(iso-latin-1-unix iso-8859-1-unix binary)) + "*Coding system used for network connections. +See also `slime-net-valid-coding-systems'.") + +(defun slime-check-coding-system (coding-system) + "Signal an error if CODING-SYSTEM isn't a valid coding system." + (interactive) + (let ((props (slime-find-coding-system coding-system))) + (unless props + (error "Invalid slime-net-coding-system: %s. %s" + coding-system (mapcar #'car slime-net-valid-coding-systems))) + (when (and (second props) (boundp 'default-enable-multibyte-characters)) + (assert default-enable-multibyte-characters)) + t)) + +(defcustom slime-repl-history-file-coding-system + (cond ((slime-find-coding-system 'utf-8-unix) 'utf-8-unix) + (t slime-net-coding-system)) + "*The coding system for the history file." + :type 'symbol + :group 'slime-repl) + +(defun slime-coding-system-mulibyte-p (coding-system) + (second (slime-find-coding-system coding-system))) + +(defun slime-coding-system-cl-name (coding-system) + (third (slime-find-coding-system coding-system))) + +;;; Interface +(defun slime-net-send (sexp proc) + "Send a SEXP to Lisp over the socket PROC. +This is the lowest level of communication. The sexp will be READ and +EVAL'd by Lisp." + (let* ((msg (concat (slime-prin1-to-string sexp) "\n")) + (string (concat (slime-net-encode-length (length msg)) msg)) + (coding-system (cdr (process-coding-system proc)))) + (slime-log-event sexp) + (cond ((slime-safe-encoding-p coding-system string) + (process-send-string proc string)) + (t (error "Coding system %s not suitable for %S" + coding-system string))))) + +(defun slime-safe-encoding-p (coding-system string) + "Return true iff CODING-SYSTEM can safely encode STRING." + (if (featurep 'xemacs) + ;; FIXME: XEmacs encodes non-encodeable chars as ?~ automatically + t + (or (let ((candidates (find-coding-systems-string string)) + (base (coding-system-base coding-system))) + (or (equal candidates '(undecided)) + (memq base candidates))) + (and (not (multibyte-string-p string)) + (not (slime-coding-system-mulibyte-p coding-system)))))) + +(defun slime-net-close (process &optional debug) + (setq slime-net-processes (remove process slime-net-processes)) + (when (eq process slime-default-connection) + (setq slime-default-connection nil)) + (cond (debug + (set-process-sentinel process 'ignore) + (set-process-filter process 'ignore) + (delete-process process)) + (t + (run-hook-with-args 'slime-net-process-close-hooks process) + ;; killing the buffer also closes the socket + (kill-buffer (process-buffer process))))) + +(defun slime-net-sentinel (process message) + (message "Lisp connection closed unexpectedly: %s" message) + (slime-net-close process) + (slime-set-state "[not connected]" process)) + +;;; Socket input is handled by `slime-net-filter', which decodes any +;;; complete messages and hands them off to the event dispatcher. + +(defun slime-net-filter (process string) + "Accept output from the socket and process all complete messages." + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string)) + (slime-process-available-input process)) + +(defun slime-run-when-idle (function &rest args) + "Call FUNCTION as soon as Emacs is idle." + (apply #'run-at-time + (if (featurep 'xemacs) itimer-short-interval 0) + nil function args)) + +(defun slime-process-available-input (process) + "Process all complete messages that have arrived from Lisp." + (with-current-buffer (process-buffer process) + (while (slime-net-have-input-p) + (let ((event (slime-net-read-or-lose process)) + (ok nil)) + (slime-log-event event) + (unwind-protect + (save-current-buffer + (slime-dispatch-event event process) + (setq ok t)) + (unless ok + (slime-run-when-idle 'slime-process-available-input process))))))) + +(defun slime-net-have-input-p () + "Return true if a complete message is available." + (goto-char (point-min)) + (and (>= (buffer-size) 6) + (>= (- (buffer-size) 6) (slime-net-decode-length)))) + +(defun slime-net-read-or-lose (process) + (condition-case error + (slime-net-read) + (error + (debug) + (slime-net-close process t) + (error "net-read error: %S" error)))) + +(defun slime-net-read () + "Read a message from the network buffer." + (goto-char (point-min)) + (let* ((length (slime-net-decode-length)) + (start (+ 6 (point))) + (end (+ start length))) + (assert (plusp length)) + (let ((string (buffer-substring-no-properties start end))) + (prog1 (read string) + (delete-region (point-min) end))))) + +(defun slime-net-decode-length () + "Read a 24-bit hex-encoded integer from buffer." + (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) 16)) + +(defun slime-net-encode-length (n) + "Encode an integer into a 24-bit hex string." + (format "%06x" n)) + +(defun slime-prin1-to-string (sexp) + "Like `prin1-to-string' but don't octal-escape non-ascii characters. +This is more compatible with the CL reader." + (with-temp-buffer + (let ((print-escape-nonascii nil) + (print-escape-newlines nil)) + (prin1 sexp (current-buffer)) + (buffer-string)))) + + +;;;; Connections +;;; +;;; "Connections" are the high-level Emacs<->Lisp networking concept. +;;; +;;; Emacs has a connection to each Lisp process that it's interacting +;;; with. Typically there would only be one, but a user can choose to +;;; connect to many Lisps simultaneously. +;;; +;;; A connection consists of a control socket, optionally an extra +;;; socket dedicated to receiving Lisp output (an optimization), and a +;;; set of connection-local state variables. +;;; +;;; The state variables are stored as buffer-local variables in the +;;; control socket's process-buffer and are used via accessor +;;; functions. These variables include things like the *FEATURES* list +;;; and Unix Pid of the Lisp process. +;;; +;;; One connection is "current" at any given time. This is: +;;; `slime-dispatching-connection' if dynamically bound, or +;;; `slime-buffer-connection' if this is set buffer-local, or +;;; `slime-default-connection' otherwise. +;;; +;;; When you're invoking commands in your source files you'll be using +;;; `slime-default-connection'. This connection can be interactively +;;; reassigned via the connection-list buffer. +;;; +;;; When a command creates a new buffer it will set +;;; `slime-buffer-connection' so that commands in the new buffer will +;;; use the connection that the buffer originated from. For example, +;;; the apropos command creates the *Apropos* buffer and any command +;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the +;;; apropos search. REPL buffers are similarly tied to their +;;; respective connections. +;;; +;;; When Emacs is dispatching some network message that arrived from a +;;; connection it will dynamically bind `slime-dispatching-connection' +;;; so that the event will be processed in the context of that +;;; connection. +;;; +;;; This is mostly transparent. The user should be aware that he can +;;; set the default connection to pick which Lisp handles commands in +;;; Lisp-mode source buffers, and slime hackers should be aware that +;;; they can tie a buffer to a specific connection. The rest takes +;;; care of itself. + +(defvar slime-dispatching-connection nil + "Network process currently executing. +This is dynamically bound while handling messages from Lisp; it +overrides `slime-buffer-connection' and `slime-default-connection'.") + +(make-variable-buffer-local + (defvar slime-buffer-connection nil + "Network connection to use in the current buffer. +This overrides `slime-default-connection'.")) + +(defvar slime-default-connection nil + "Network connection to use by default. +Used for all Lisp communication, except when overridden by +`slime-dispatching-connection' or `slime-buffer-connection'.") + +(defun slime-current-connection () + "Return the connection to use for Lisp interaction. +Return nil if there's no connection." + (or slime-dispatching-connection + slime-buffer-connection + slime-default-connection)) + +(defun slime-connection () + "Return the connection to use for Lisp interaction. +Signal an error if there's no connection." + (let ((conn (slime-current-connection))) + (cond ((and (not conn) slime-net-processes) + (error "No default connection selected.")) + ((not conn) + (error "Not connected.")) + ((not (eq (process-status conn) 'open)) + (error "Connection closed.")) + (t conn)))) + +(defun slime-select-connection (process) + "Make PROCESS the default connection." + (setq slime-default-connection process)) + +(defmacro* slime-with-connection-buffer ((&optional process) &rest body) + "Execute BODY in the process-buffer of PROCESS. +If PROCESS is not specified, `slime-connection' is used. + +\(fn (&optional PROCESS) &body BODY))" + `(with-current-buffer + (process-buffer (or ,process (slime-connection) + (error "No connection"))) + ,@body)) + +(put 'slime-with-connection-buffer 'lisp-indent-function 1) + +(defvar slime-state-name "[??]" + "Name of the current state of `slime-default-connection'. +Just used for informational display in the mode-line.") + +(defun slime-set-state (name &optional connection) + "Set the current connection's informational state name. +If this is the default connection then the state will be displayed in +the modeline." + (when (or (not (slime-connected-p)) + (eq (or connection (slime-connection)) slime-default-connection)) + (setq slime-state-name name) + (force-mode-line-update))) + +;;; Connection-local variables: + +(defmacro slime-def-connection-var (varname &rest initial-value-and-doc) + "Define a connection-local variable. +The value of the variable can be read by calling the function of the +same name (it must not be accessed directly). The accessor function is +setf-able. + +The actual variable bindings are stored buffer-local in the +process-buffers of connections. The accessor function refers to +the binding for `slime-connection'." + (let ((real-var (intern (format "%s:connlocal" varname)))) + `(progn + ;; Variable + (make-variable-buffer-local + (defvar ,real-var ,@initial-value-and-doc)) + ;; Accessor + (defun ,varname (&optional process) + (slime-with-connection-buffer (process) ,real-var)) + ;; Setf + (defsetf ,varname (&optional process) (store) + `(slime-with-connection-buffer (,process) + (setq (\, (quote (\, real-var))) (\, store)) + (\, store))) + '(\, varname)))) + +(put 'slime-def-connection-var 'lisp-indent-function 2) + +;; Let's indulge in some pretty colours. +(unless (featurep 'xemacs) + (font-lock-add-keywords + 'emacs-lisp-mode + '(("(\$slime-def-connection-var\$\\s +\$\\(\\w\\|\\s_\$+\\)" + (1 font-lock-keyword-face) + (2 font-lock-variable-name-face))))) + +(slime-def-connection-var slime-connection-number nil + "Serial number of a connection. +Bound in the connection's process-buffer.") + +(slime-def-connection-var slime-lisp-features '() + "The symbol-names of Lisp's *FEATURES*. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-lisp-package + "COMMON-LISP-USER" + "The current package name of the Superior lisp. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-lisp-package-prompt-string + "CL-USER" + "The current package name of the Superior lisp. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-pid nil + "The process id of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-type nil + "The implementation type of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-version nil + "The implementation type of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-name nil + "The short name for the Lisp implementation.") + +(slime-def-connection-var slime-connection-name nil + "The short name for connection.") + +(slime-def-connection-var slime-inferior-process nil + "The inferior process for the connection if any.") + +(slime-def-connection-var slime-communication-style nil + "The communication style.") + +(slime-def-connection-var slime-machine-instance nil + "The name of the (remote) machine running the Lisp process.") + +;;;;; Connection setup + +(defvar slime-connection-counter 0 + "The number of SLIME connections made. For generating serial numbers.") + +;;; Interface +(defun slime-setup-connection (process) + "Make a connection out of PROCESS." + (let ((slime-dispatching-connection process)) + (slime-init-connection-state process) + (slime-select-connection process) + process)) + +(defun slime-init-connection-state (proc) + "Initialize connection state in the process-buffer of PROC." + ;; To make life simpler for the user: if this is the only open + ;; connection then reset the connection counter. + (when (equal slime-net-processes (list proc)) + (setq slime-connection-counter 0)) + (slime-with-connection-buffer () + (setq slime-buffer-connection proc)) + (setf (slime-connection-number proc) (incf slime-connection-counter)) + ;; We do the rest of our initialization asynchronously. The current + ;; function may be called from a timer, and if we setup the REPL + ;; from a timer then it mysteriously uses the wrong keymap for the + ;; first command. + (slime-eval-async '(swank:connection-info) + (with-lexical-bindings (proc) + (lambda (info) + (slime-set-connection-info proc info))))) + +(defun slime-set-connection-info (connection info) + "Initialize CONNECTION with INFO received from Lisp." + (let ((slime-dispatching-connection connection)) + (destructuring-bind (&key pid style lisp-implementation machine + features package version &allow-other-keys) info + (or (equal version slime-protocol-version) + (yes-or-no-p "Protocol version mismatch. Continue anyway? ") + (slime-net-close connection) + (top-level)) + (setf (slime-pid) pid + (slime-communication-style) style + (slime-lisp-features) features) + (destructuring-bind (&key name prompt) package + (setf (slime-lisp-package) name + (slime-lisp-package-prompt-string) prompt)) + (destructuring-bind (&key type name version) lisp-implementation + (setf (slime-lisp-implementation-type) type + (slime-lisp-implementation-version) version + (slime-lisp-implementation-name) name + (slime-connection-name) (slime-generate-connection-name name))) + (destructuring-bind (&key instance type version) machine + (setf (slime-machine-instance) instance))) + (setq slime-state-name "") ; FIXME + (let ((args (when-let (p (slime-inferior-process)) + (slime-inferior-lisp-args p)))) + (when-let (name (plist-get args ':name)) + (unless (string= (slime-lisp-implementation-name) name) + (setf (slime-connection-name) + (slime-generate-connection-name (symbol-name name))))) + (slime-hide-inferior-lisp-buffer) + (slime-init-output-buffer connection) + (run-hooks 'slime-connected-hook) + (when-let (fun (plist-get args ':init-function)) + (funcall fun))) + (message "Connected. %s" (slime-random-words-of-encouragement)))) + +(defun slime-generate-connection-name (lisp-name) + (loop for i from 1 + for name = lisp-name then (format "%s<%d>" lisp-name i) + while (find name slime-net-processes + :key #'slime-connection-name :test #'equal) + finally (return name))) + +(defun slime-connection-close-hook (process) + (when (eq process slime-default-connection) + (when slime-net-processes + (slime-select-connection (car slime-net-processes)) + (message "Default connection closed; switched to #%S (%S)" + (slime-connection-number) + (slime-connection-name))))) + +(add-hook 'slime-net-process-close-hooks 'slime-connection-close-hook) + +;;;;; Commands on connections + +(defun slime-disconnect () + "Disconnect all connections." + (interactive) + (mapc #'slime-net-close slime-net-processes)) + +(defun slime-make-default-connection () + "Make the current connection the default connection." + (interactive) + (slime-select-connection (slime-connection)) + (message "Connection #%S (%s) now default SLIME connection." + (slime-connection-number) + (slime-connection-name))) + +(defun slime-choose-connection () + "Return an established connection chosen by the user." + (let ((default (slime-connection-name))) + (slime-find-connection-by-name + (completing-read (format "Connection name (default %s): " default) + (slime-bogus-completion-alist + (mapcar #'slime-connection-name slime-net-processes)) + nil + t + nil + nil + default)))) + +(defun slime-find-connection-by-name (name) + (find name slime-net-processes + :test #'string= :key #'slime-connection-name)) + +(defun slime-connection-port (connection) + "Return the remote port number of CONNECTION." + (if (featurep 'xemacs) + (car (process-id connection)) + (cadr (process-contact connection)))) + +(defun slime-process (&optional connection) + "Return the Lisp process for CONNECTION (default `slime-connection'). +Can return nil if there's no process object for the connection." + (let ((proc (slime-inferior-process connection))) + (if (and proc + (memq (process-status proc) '(run stop))) + proc))) + +;; Non-macro version to keep the file byte-compilable. +(defun slime-set-inferior-process (connection process) + (setf (slime-inferior-process connection) process)) + +(defun slime-use-sigint-for-interrupt (&optional connection) + (let ((c (or connection (slime-connection)))) + (ecase (slime-communication-style c) + ((:fd-handler nil) t) + ((:spawn :sigio) nil)))) + +(defvar slime-inhibit-pipelining t + "*If true, don't send background requests if Lisp is already busy.") + +(defun slime-background-activities-enabled-p () + (and (or slime-mode + (eq major-mode 'sldb-mode) + (eq major-mode 'slime-repl-mode)) + (let ((con (slime-current-connection))) + (and con + (eq (process-status con) 'open))) + (or (not (slime-busy-p)) + (not slime-inhibit-pipelining)))) + + +;;;; Communication protocol + +;;;;; Emacs Lisp programming interface +;;; +;;; The programming interface for writing Emacs commands is based on +;;; remote procedure calls (RPCs). The basic operation is to ask Lisp +;;; to apply a named Lisp function to some arguments, then to do +;;; something with the result. +;;; +;;; Requests can be either synchronous (blocking) or asynchronous +;;; (with the result passed to a callback/continuation function). If +;;; an error occurs during the request then the debugger is entered +;;; before the result arrives -- for synchronous evaluations this +;;; requires a recursive edit. +;;; +;;; You should use asynchronous evaluations (`slime-eval-async') for +;;; most things. Reserve synchronous evaluations (`slime-eval') for +;;; the cases where blocking Emacs is really appropriate (like +;;; completion) and that shouldn't trigger errors (e.g. not evaluate +;;; user-entered code). +;;; +;;; We have the concept of the "current Lisp package". RPC requests +;;; always say what package the user is making them from and the Lisp +;;; side binds that package to *BUFFER-PACKAGE* to use as it sees +;;; fit. The current package is defined as the buffer-local value of +;;; `slime-buffer-package' if set, and otherwise the package named by +;;; the nearest IN-PACKAGE as found by text search (first backwards, +;;; then forwards). +;;; +;;; Similarly we have the concept of the current thread, i.e. which +;;; thread in the Lisp process should handle the request. The current +;;; thread is determined solely by the buffer-local value of +;;; `slime-current-thread'. This is usually bound to t meaning "no +;;; particular thread", but can also be used to nominate a specific +;;; thread. The REPL and the debugger both use this feature to deal +;;; with specific threads. + +(make-variable-buffer-local + (defvar slime-current-thread t + "The id of the current thread on the Lisp side. +t means the \"current\" thread; +:repl-thread the thread that executes REPL requests; +fixnum a specific thread.")) + +(make-variable-buffer-local + (defvar slime-buffer-package nil + "The Lisp package associated with the current buffer. +This is set only in buffers bound to specific packages.")) + +;;; `slime-rex' is the RPC primitive which is used to implement both +;;; `slime-eval' and `slime-eval-async'. You can use it directly if +;;; you need to, but the others are usually more convenient. + +(defmacro* slime-rex ((&rest saved-vars) + (sexp &optional + (package '(slime-current-package)) + (thread 'slime-current-thread)) + &rest continuations) + "(slime-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...) + +Remote EXecute SEXP. + +VARs are a list of saved variables visible in the other forms. Each +VAR is either a symbol or a list (VAR INIT-VALUE). + +SEXP is evaluated and the princed version is sent to Lisp. + +PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package. +The default value is (slime-current-package). + +CLAUSES is a list of patterns with same syntax as +`destructure-case'. The result of the evaluation of SEXP is +dispatched on CLAUSES. The result is either a sexp of the +form (:ok VALUE) or (:abort). CLAUSES is executed +asynchronously. + +Note: don't use backquote syntax for SEXP, because Emacs20 cannot +deal with that." + (let ((result (gensym))) + `(lexical-let ,(loop for var in saved-vars + collect (etypecase var + (symbol (list var var)) + (cons var))) + (slime-dispatch-event + (list :emacs-rex ,sexp ,package ,thread + (lambda (,result) + (destructure-case ,result + ,@continuations))))))) + +(put 'slime-rex 'lisp-indent-function 2) + +;;; Interface +(defun slime-current-package () + "Return the Common Lisp package in the current context. +If `slime-buffer-package' has a value then return that, otherwise +search for and read an `in-package' form. + +The REPL buffer is a special case: it's package is `slime-lisp-package'." + (cond ((eq major-mode 'slime-repl-mode) + (slime-lisp-package)) + (slime-buffer-package) + (t (save-restriction + (widen) + (slime-find-buffer-package))))) + +(defvar slime-find-buffer-package-function 'slime-search-buffer-package + "*Function to use for `slime-find-buffer-package'. +The result should be the package-name (a string) +or nil if nothing suitable can be found.") + +(defun slime-find-buffer-package () + "Figure out which Lisp package the current buffer is associated with." + (funcall slime-find-buffer-package-function)) + +;; When modifing this code consider cases like: +;; (in-package #.*foo*) +;; (in-package #:cl) +;; (in-package :cl) +;; (in-package "CL") +;; (in-package |CL|) +;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp) +(defun slime-search-buffer-package () + (let ((case-fold-search t) + (regexp (concat "^(\$cl:\\|common-lisp:\$?in-package\\>[ \n\t\r']*" + "\$[^)]+\$[ \n\t]*)"))) + (save-excursion + (when (or (re-search-backward regexp nil t) + (re-search-forward regexp nil t)) + (let ((string (match-string-no-properties 2))) + (cond ((string-match "^\"" string) (ignore-errors (read string))) + ((string-match "^#?:" string) (substring string (match-end 0))) + (t string))))))) + +;;; Synchronous requests are implemented in terms of asynchronous +;;; ones. We make an asynchronous request with a continuation function +;;; that `throw's its result up to a `catch' and then enter a loop of +;;; handling I/O until that happens. + +(defvar slime-stack-eval-tags nil + "List of stack-tags of continuations waiting on the stack.") + +(defun slime-eval (sexp &optional package) + "Evaluate EXPR on the superior Lisp and return the result." + (when (null package) (setq package (slime-current-package))) + (let* ((tag (gensym (format "slime-result-%d-" + (1+ (slime-continuation-counter))))) + (slime-stack-eval-tags (cons tag slime-stack-eval-tags))) + (apply + #'funcall + (catch tag + (slime-rex (tag sexp) + (sexp package) + ((:ok value) + (unless (member tag slime-stack-eval-tags) + (error "tag = %S eval-tags = %S sexp = %S" + tag slime-stack-eval-tags sexp)) + (throw tag (list #'identity value))) + ((:abort) + (throw tag (list #'error "Synchronous Lisp Evaluation aborted.")))) + (let ((debug-on-quit t) + (inhibit-quit nil) + (conn (slime-connection))) + (while t + (unless (eq (process-status conn) 'open) + (error "Lisp connection closed unexpectedly")) + (slime-accept-process-output nil 0.01))))))) + +(defun slime-eval-async (sexp &optional cont package) + "Evaluate EXPR on the superior Lisp and call CONT with the result." + (slime-rex (cont (buffer (current-buffer))) + (sexp (or package (slime-current-package))) + ((:ok result) + (when cont + (set-buffer buffer) + (funcall cont result))) + ((:abort) + (message "Evaluation aborted.")))) + +;;; These functions can be handy too: + +(defun slime-connected-p () + "Return true if the Swank connection is open." + (not (null slime-net-processes))) + +(defun slime-check-connected () + "Signal an error if we are not connected to Lisp." + (unless (slime-connected-p) + (error "Not connected. Use `%s' to start a Lisp." + (substitute-command-keys "\\[slime]")))) + +(defun slime-busy-p () + "True if Lisp has outstanding requests. +Debugged requests are ignored." + (let ((debugged (sldb-debugged-continuations (slime-connection)))) + (remove-if (lambda (id) + (memq id debugged)) + (slime-rex-continuations) + :key #'car))) + +;; dummy defvar for compiler +(defvar slime-repl-read-mode) + +(defun slime-reading-p () + "True if Lisp is currently reading input from the REPL." + (with-current-buffer (slime-output-buffer) + slime-repl-read-mode)) + +(defun slime-sync () + "Block until the most recent request has finished." + (when (slime-rex-continuations) + (let ((tag (caar (slime-rex-continuations)))) + (while (find tag (slime-rex-continuations) :key #'car) + (slime-accept-process-output nil 0.1))))) + +(defun slime-ping () + "Check that communication works." + (interactive) + (message "%s" (slime-eval "PONG"))) + +;;;;; Protocol event handler (the guts) +;;; +;;; This is the protocol in all its glory. The input to this function +;;; is a protocol event that either originates within Emacs or arrived +;;; over the network from Lisp. +;;; +;;; Each event is a list beginning with a keyword and followed by +;;; arguments. The keyword identifies the type of event. Events +;;; originating from Emacs have names starting with :emacs- and events +;;; from Lisp don't. + +(slime-def-connection-var slime-rex-continuations '() + "List of (ID . FUNCTION) continuations waiting for RPC results.") + +(slime-def-connection-var slime-continuation-counter 0 + "Continuation serial number counter.") + +(defvar slime-event-hooks) + +(defun slime-dispatch-event (event &optional process) + (let ((slime-dispatching-connection (or process (slime-connection)))) + (or (run-hook-with-args-until-success 'slime-event-hooks event) + (destructure-case event + ((:write-string output &optional target) + (slime-write-string output target)) + ((:emacs-rex form package thread continuation) + (slime-set-state "|eval...") + (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) + (message "; pipelined request... %S" form)) + (let ((id (incf (slime-continuation-counter)))) + (push (cons id continuation) (slime-rex-continuations)) + (slime-send `(:emacs-rex ,form ,package ,thread ,id)))) + ((:return value id) + (let ((rec (assq id (slime-rex-continuations)))) + (cond (rec (setf (slime-rex-continuations) + (remove rec (slime-rex-continuations))) + (when (null (slime-rex-continuations)) + (slime-set-state "")) + (funcall (cdr rec) value)) + (t + (error "Unexpected reply: %S %S" id value))))) + ((:debug-activate thread level) + (assert thread) + (sldb-activate thread level)) + ((:debug thread level condition restarts frames conts) + (assert thread) + (sldb-setup thread level condition restarts frames conts)) + ((:debug-return thread level stepping) + (assert thread) + (sldb-exit thread level stepping)) + ((:emacs-interrupt thread) + (slime-send `(:emacs-interrupt ,thread))) + ((:read-string thread tag) + (assert thread) + (slime-repl-read-string thread tag)) + ((:y-or-n-p thread tag question) + (slime-y-or-n-p thread tag question)) + ((:read-aborted thread tag) + (assert thread) + (slime-repl-abort-read thread tag)) + ((:emacs-return-string thread tag string) + (slime-send `(:emacs-return-string ,thread ,tag ,string))) + ;; + ((:new-package package prompt-string) + (setf (slime-lisp-package) package) + (setf (slime-lisp-package-prompt-string) prompt-string)) + ((:new-features features) + (setf (slime-lisp-features) features)) + ((:indentation-update info) + (slime-handle-indentation-update info)) + ((:open-dedicated-output-stream port) + (slime-open-stream-to-lisp port)) + ((:eval-no-wait fun args) + (apply (intern fun) args)) + ((:eval thread tag form-string) + (slime-check-eval-in-emacs-enabled) + (slime-eval-for-lisp thread tag form-string)) + ((:emacs-return thread tag value) + (slime-send `(:emacs-return ,thread ,tag ,value))) + ((:ed what) + (slime-ed what)) + ((:inspect what) + (slime-open-inspector what)) + ((:background-message message) + (slime-background-message "%s" message)) + ((:debug-condition thread message) + (assert thread) + (message "%s" message)))))) + +(defun slime-send (sexp) + "Send SEXP directly over the wire on the current connection." + (slime-net-send sexp (slime-connection))) + +(defun slime-reset () + "Clear all pending continuations." + (interactive) + (setf (slime-rex-continuations) '()) + (mapc #'kill-buffer (sldb-buffers))) + +(defun slime-send-sigint () + (interactive) + (signal-process (slime-pid) 'SIGINT)) + +;;;;; Event logging to *slime-events* +;;; +;;; The *slime-events* buffer logs all protocol messages for debugging +;;; purposes. Optionally you can enable outline-mode in that buffer, +;;; which is convenient but slows things down significantly. + +(defvar slime-log-events t + "*Log protocol events to the *slime-events* buffer.") + +(defvar slime-outline-mode-in-events-buffer nil + "*Non-nil means use outline-mode in *slime-events*.") + +(defvar slime-event-buffer-name "*slime-events*" + "The name of the slime event buffer.") + +(defun slime-log-event (event) + "Record the fact that EVENT occurred." + (when slime-log-events + (with-current-buffer (slime-events-buffer) + ;; trim? + (when (> (buffer-size) 100000) + (goto-char (/ (buffer-size) 2)) + (re-search-forward "^(" nil t) + (delete-region (point-min) (point))) + (goto-char (point-max)) + (save-excursion + (slime-pprint-event event (current-buffer))) + (when (and (boundp 'outline-minor-mode) + outline-minor-mode) + (hide-entry)) + (goto-char (point-max))))) + +(defun slime-pprint-event (event buffer) + "Pretty print EVENT in BUFFER with limited depth and width." + (let ((print-length 20) + (print-level 6) + (pp-escape-newlines t)) + (pp event buffer))) + +(defun slime-events-buffer () + (or (get-buffer slime-event-buffer-name) + (let ((buffer (get-buffer-create slime-event-buffer-name))) + (with-current-buffer buffer + (set (make-local-variable 'outline-regexp) "^(") + (set (make-local-variable 'comment-start) ";") + (set (make-local-variable 'comment-end) "") + (when slime-outline-mode-in-events-buffer + (outline-minor-mode))) + buffer))) + + +;;;; Stream output + +(slime-def-connection-var slime-connection-output-buffer nil + "The buffer for the REPL. May be nil or a dead buffer.") + +(make-variable-buffer-local + (defvar slime-output-start nil + "Marker for the start of the output for the evaluation.")) + +(make-variable-buffer-local + (defvar slime-output-end nil + "Marker for end of output. New output is inserted at this mark.")) + +;; dummy definitions for the compiler +(defvar slime-repl-package-stack) +(defvar slime-repl-directory-stack) +(defvar slime-repl-input-start-mark) +(defvar slime-repl-prompt-start-mark) + + +(defun slime-output-buffer (&optional noprompt) + "Return the output buffer, create it if necessary." + (let ((buffer (slime-connection-output-buffer))) + (or (if (buffer-live-p buffer) buffer) + (setf (slime-connection-output-buffer) + (let ((connection (slime-connection))) + (with-current-buffer (slime-repl-buffer t connection) + (unless (eq major-mode 'slime-repl-mode) + (slime-repl-mode)) + (setq slime-buffer-connection connection) + (slime-reset-repl-markers) + (unless noprompt + (slime-repl-insert-prompt)) + (current-buffer))))))) + +(defvar slime-repl-banner-function 'slime-repl-insert-banner) + +(defun slime-repl-update-banner () + (funcall slime-repl-banner-function) + (goto-char (point-max)) + (slime-mark-output-start) + (slime-mark-input-start) + (slime-repl-insert-prompt) + (pop-to-buffer (current-buffer))) + +(defun slime-repl-insert-banner () + (when (zerop (buffer-size)) + (let ((welcome (concat "; SLIME " (or (slime-changelog-date) + "- ChangeLog file not found")))) + (insert welcome)))) + +(defun slime-init-output-buffer (connection) + (with-current-buffer (slime-output-buffer t) + (setq slime-buffer-connection connection + slime-repl-directory-stack '() + slime-repl-package-stack '()) + (slime-repl-update-banner))) + +(defvar slime-show-last-output-function + 'slime-maybe-display-output-buffer + "*This function is called when a evaluation request is finished. +It is called in the slime-output buffer and receives the region of the +output as arguments.") + +(defun slime-show-last-output-region (start end) + (when (< start end) + (slime-display-buffer-region (current-buffer) (1- start) + slime-repl-input-start-mark))) + +(defun slime-maybe-display-output-buffer (start end) + (when (and (< start end) + (not (get-buffer-window (current-buffer) t))) + (display-buffer (current-buffer))) + (when (eobp) + (slime-repl-show-maximum-output t))) + +(defun slime-show-last-output () + "Show the output from the last Lisp evaluation." + (with-current-buffer (slime-output-buffer) + (let ((start slime-output-start) + (end slime-output-end)) + (funcall slime-show-last-output-function start end)))) + +(defun slime-display-output-buffer () + "Display the output buffer and scroll to bottom." + (with-current-buffer (slime-output-buffer) + (goto-char (point-max)) + (unless (get-buffer-window (current-buffer) t) + (display-buffer (current-buffer) t)) + (slime-repl-show-maximum-output))) + +(defmacro slime-with-output-end-mark (&rest body) + "Execute BODY at `slime-output-end'. + +If point is initially at `slime-output-end' and the buffer is visible +update window-point afterwards. If point is initially not at +`slime-output-end, execute body inside a `save-excursion' block." + `(let ((body.. (lambda () ,@body)) + (updatep.. (and (eobp) (pos-visible-in-window-p)))) + (cond ((= (point) slime-output-end) + (let ((start.. (point))) + (funcall body..) + (set-marker slime-output-end (point)) + (when (= start.. slime-repl-input-start-mark) + (set-marker slime-repl-input-start-mark (point))))) + (t + (save-excursion + (goto-char slime-output-end) + (funcall body..)))) + (when updatep.. + (slime-repl-show-maximum-output + (> (- slime-output-end slime-output-start) 1000))))) + +(defun slime-output-filter (process string) + (with-current-buffer (process-buffer process) + (when (and (plusp (length string)) + (eq (process-status slime-buffer-connection) 'open)) + (slime-write-string string)))) + +(defvar slime-open-stream-hooks) + +(defun slime-open-stream-to-lisp (port) + (let ((stream (open-network-stream "*lisp-output-stream*" + (slime-with-connection-buffer () + (current-buffer)) + slime-lisp-host port))) + (slime-set-query-on-exit-flag stream) + (set-process-filter stream 'slime-output-filter) + (let ((pcs (process-coding-system (slime-current-connection)))) + (set-process-coding-system stream (car pcs) (cdr pcs))) + (when-let (secret (slime-secret)) + (slime-net-send secret stream)) + (run-hook-with-args 'slime-open-stream-hooks stream) + stream)) + +(defun slime-io-speed-test (&optional profile) + "A simple minded benchmark for stream performance. +If a prefix argument is given, instrument the slime package for +profiling before running the benchmark." + (interactive "P") + (eval-and-compile + (require 'elp)) + (elp-reset-all) + (elp-restore-all) + (load "slime.el") + ;;(byte-compile-file "slime-net.el" t) + ;;(setq slime-log-events nil) + (setq slime-enable-evaluate-in-emacs t) + ;;(setq slime-repl-enable-presentations nil) + (when profile + (elp-instrument-package "slime-")) + (kill-buffer (slime-output-buffer)) + ;;(display-buffer (slime-output-buffer)) + (delete-other-windows) + (sit-for 0) + (slime-repl-send-string "(swank:io-speed-test 5000 1)") + (let ((proc (slime-inferior-process))) + (when proc + (switch-to-buffer (process-buffer proc)) + (goto-char (point-max))))) + +(defvar slime-write-string-function 'slime-repl-write-string) + +(defun slime-write-string (string &optional target) + "Insert STRING in the REPL buffer or some other TARGET. +If TARGET is nil, insert STRING as regular process +output. If TARGET is :repl-result, insert STRING as the result of the +evaluation. Other values of TARGET map to an Emacs marker via the +hashtable `slime-output-target-to-marker'; output is inserted at this marker." + (funcall slime-write-string-function string target)) + +(defun slime-repl-write-string (string &optional target) + (case target + ((nil) (slime-repl-emit string)) + (:repl-result (slime-repl-emit-result string)) + (t (slime-emit-string string target)))) + +(defun slime-repl-emit (string) + ;; insert the string STRING in the output buffer + (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (slime-insert-propertized '(face slime-repl-output-face + rear-nonsticky (face)) + string) + (set-marker slime-output-end (point)) + (when (and (= (point) slime-repl-prompt-start-mark) + (not (bolp))) + (insert "\n") + (set-marker slime-output-end (1- (point)))) + (when (< slime-repl-input-start-mark (point)) + (set-marker slime-repl-input-start-mark (point)))))) + +(defun slime-repl-emit-result (string) + ;; insert STRING and mark it as evaluation result + (with-current-buffer (slime-output-buffer) + (goto-char slime-repl-input-start-mark) + (slime-insert-propertized `(face slime-repl-result-face + rear-nonsticky (face)) + string) + (set-marker slime-repl-input-start-mark (point)))) + +(defvar slime-last-output-target-id 0 + "The last integer we used as a TARGET id.") + +(defvar slime-output-target-to-marker + (make-hash-table) + "Map from TARGET ids to Emacs markers. +The markers indicate where output should be inserted.") + +(defun slime-output-target-marker (target) + "Return the marker where output for TARGET should be inserted." + (case target + ((nil) + (with-current-buffer (slime-output-buffer) + slime-output-end)) + (:repl-result + (with-current-buffer (slime-output-buffer) + slime-repl-input-start-mark)) + (t + (gethash target slime-output-target-to-marker)))) + +(defun slime-emit-string (string target) + "Insert STRING at target TARGET. +See `slime-output-target-to-marker'." + (let* ((marker (slime-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (when buffer + (with-current-buffer buffer + (save-excursion + ;; Insert STRING at MARKER, then move MARKER behind + ;; the insertion. + (goto-char marker) + (insert-before-markers string) + (set-marker marker (point))))))) + +(defun slime-switch-to-output-buffer (&optional connection) + "Select the output buffer, preferably in a different window." + (interactive (list (if prefix-arg (slime-choose-connection)))) + (let ((slime-dispatching-connection (or connection + slime-dispatching-connection))) + (set-buffer (slime-output-buffer)) + (unless (eq (current-buffer) (window-buffer)) + (pop-to-buffer (current-buffer) t)) + (goto-char (point-max)))) + + +;;;; REPL +;; +;; The REPL uses some markers to separate input from output. The +;; usual configuration is as follows: +;; +;; ... output ... ... result ... prompt> ... input ... +;; ^ ^ ^ ^ ^ +;; output-start output-end prompt-start input-start input-end +;; +;; output-start and input-start are right inserting markers; +;; output-end and input-end left inserting. +;; +;; We maintain the following invariant: +;; +;; output-start <= output-end <= input-start <= input-end. +;; +;; This invariant is important, because we must be prepared for +;; asynchronous output and asynchronous reads. ("Asynchronous" means, +;; triggered by Lisp and not by Emacs.) +;; +;; All output is inserted at the output-end marker. Some care must be +;; taken when output-end and input-start are at the same position: if +;; we blindly insert at that point, we break the invariant stated +;; above, because the output-end marker is left inserting. The macro +;; `slime-with-output-end-mark' handles this complication by moving +;; the input-start marker to an appropriate place. The macro also +;; updates window-point if necessary, and tries to keep the prompt in +;; the first column by inserting a newline. +;; +;; A "synchronous" evaluation request proceeds as follows: the user +;; inserts some text between input-start and input-end and then hits +;; return. We send the text between the input markers to Lisp, move +;; the output and input makers to the line after the input and wait. +;; When we receive the result, we insert it together with a prompt +;; between the output-end and input-start mark. +;; `slime-repl-insert-prompt' does this. +;; +;; It is possible that some output for such an evaluation request +;; arrives after the result. This output is inserted before the +;; result (and before the prompt). Output that doesn't belong the +;; evaluation request should not be inserted before the result, but +;; immediately before the prompt. To achieve this, we move the +;; output-end mark to prompt-start after a short delay (by starting a +;; timer in `slime-repl-insert-prompt'). In summary: synchronous +;; output should go before the result, asynchronous before the prompt. +;; +;; If we are in "reading" state, e.g., during a call to Y-OR-N-P, +;; there is no prompt between output-end and input-start. +;; + +;; Small helper. +(defun slime-make-variables-buffer-local (&rest variables) + (mapcar #'make-variable-buffer-local variables)) + +(slime-make-variables-buffer-local + (defvar slime-repl-package-stack nil + "The stack of packages visited in this repl.") + + (defvar slime-repl-directory-stack nil + "The stack of default directories associated with this repl.") + + (defvar slime-repl-prompt-start-mark) + (defvar slime-repl-input-start-mark) + (defvar slime-repl-input-end-mark) + (defvar slime-repl-last-input-start-mark) + (defvar slime-repl-old-input-counter 0 + "Counter used to generate unique `slime-repl-old-input' properties. +This property value must be unique to avoid having adjacent inputs be +joined together.")) + +(defun slime-reset-repl-markers () + (dolist (markname '(slime-output-start + slime-output-end + slime-repl-prompt-start-mark + slime-repl-input-start-mark + slime-repl-input-end-mark + slime-repl-last-input-start-mark)) + (set markname (make-marker)) + (set-marker (symbol-value markname) (point))) + ;; (set-marker-insertion-type slime-output-end t) + (set-marker-insertion-type slime-repl-input-end-mark t) + (set-marker-insertion-type slime-repl-prompt-start-mark t)) + +;;;;; REPL mode setup + +(defvar slime-repl-mode-map) + +(setq slime-repl-mode-map (make-sparse-keymap)) +(set-keymap-parent slime-repl-mode-map lisp-mode-map) + +(dolist (spec slime-keys) + (destructuring-bind (key command &key inferior prefixed + &allow-other-keys) spec + (when inferior + (let ((key (if prefixed (concat slime-prefix-key key) key))) + (define-key slime-repl-mode-map key command))))) + +(slime-define-keys slime-repl-mode-map + ("\C-m" 'slime-repl-return) + ("\C-j" 'slime-repl-newline-and-indent) + ("\C-\M-m" 'slime-repl-closing-return) + ([(control return)] 'slime-repl-closing-return) + ("\C-a" 'slime-repl-bol) + ([home] 'slime-repl-bol) + ("\C-e" 'slime-repl-eol) + ("\M-p" 'slime-repl-previous-input) + ((kbd "C-<up>") 'slime-repl-backward-input) + ("\M-n" 'slime-repl-next-input) + ((kbd "C-<down>") 'slime-repl-forward-input) + ("\M-r" 'slime-repl-previous-matching-input) + ("\M-s" 'slime-repl-next-matching-input) + ("\C-c\C-c" 'slime-interrupt) + ("\C-c\C-b" 'slime-interrupt) + ("\C-c:" 'slime-interactive-eval) + ("\C-c\C-e" 'slime-interactive-eval) + ("\C-cE" 'slime-edit-value) + ;("\t" 'slime-complete-symbol) + ("\t" 'slime-indent-and-complete-symbol) + (" " 'slime-space) + ("\C-c\C-d" slime-doc-map) + ("\C-c\C-w" slime-who-map) + ("\C-\M-x" 'slime-eval-defun) + ("\C-c\C-o" 'slime-repl-clear-output) + ("\C-c\C-t" 'slime-repl-clear-buffer) + ("\C-c\C-u" 'slime-repl-kill-input) + ("\C-c\C-n" 'slime-repl-next-prompt) + ("\C-c\C-p" 'slime-repl-previous-prompt) + ("\C-c\C-l" 'slime-load-file) + ("\C-c\C-k" 'slime-compile-and-load-file) + ("\C-c\C-z" 'slime-nop)) + +(defun slime-repl-mode () + "Major mode for interacting with a superior Lisp. +\\{slime-repl-mode-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'slime-repl-mode) + (use-local-map slime-repl-mode-map) + (lisp-mode-variables t) + (set (make-local-variable 'lisp-indent-function) + 'common-lisp-indent-function) + (setq font-lock-defaults nil) + (setq mode-name "REPL") + (setq slime-current-thread :repl-thread) + (set (make-local-variable 'scroll-conservatively) 20) + (set (make-local-variable 'scroll-margin) 0) + (slime-repl-safe-load-history) + (add-local-hook 'kill-buffer-hook 'slime-repl-safe-save-merged-history) + (add-hook 'kill-emacs-hook 'slime-repl-save-all-histories) + (slime-setup-command-hooks) + ;; At the REPL, we define beginning-of-defun and end-of-defun to be + ;; the start of the previous prompt or next prompt respectively. + ;; Notice the interplay with SLIME-REPL-BEGINNING-OF-DEFUN. + (set (make-local-variable 'beginning-of-defun-function) + 'slime-repl-mode-beginning-of-defun) + (set (make-local-variable 'end-of-defun-function) + 'slime-repl-mode-end-of-defun) + (run-hooks 'slime-repl-mode-hook)) + +(defun slime-repl-buffer (&optional create connection) + "Get the REPL buffer for the current connection; optionally create." + (funcall (if create #'get-buffer-create #'get-buffer) + (format "*slime-repl %s*" (slime-connection-name connection)))) + +(defun slime-repl () + (interactive) + (slime-switch-to-output-buffer)) + +(defun slime-repl-mode-beginning-of-defun () + (slime-repl-previous-prompt) + t) + +(defun slime-repl-mode-end-of-defun () + (slime-repl-next-prompt) + t) + +(defun slime-repl-send-string (string &optional command-string) + (cond (slime-repl-read-mode + (slime-repl-return-string string)) + (t (slime-repl-eval-string string)))) + +(defun slime-repl-eval-string (string) + (slime-rex () + ((list 'swank:listener-eval string) (slime-lisp-package)) + ((:ok result) + (slime-repl-insert-result result)) + ((:abort) + (slime-repl-show-abort)))) + +(defun slime-repl-insert-result (result) + (with-current-buffer (slime-output-buffer) + (goto-char (point-max)) + (when result + (destructure-case result + ((:values &rest strings) + (unless (bolp) (insert "\n")) + (cond ((null strings) + (insert "; No value\n")) + (t + (dolist (string strings) + (slime-propertize-region `(face slime-repl-result-face) + (insert string)) + (insert "\n"))))))) + (slime-repl-insert-prompt))) + +(defun slime-repl-show-abort () + (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (unless (bolp) (insert-before-markers "\n")) + (insert-before-markers "; Evaluation aborted.\n")) + (slime-repl-insert-prompt))) + +(defun slime-repl-insert-prompt () + "Goto to point max, and insert the prompt." + (goto-char slime-repl-input-start-mark) + (assert (= slime-repl-input-end-mark (point-max))) + (unless (bolp) (insert "\n")) + (let ((prompt-start (point)) + (prompt (format "%s> " (slime-lisp-package-prompt-string)))) + (slime-propertize-region + '(face slime-repl-prompt-face read-only t intangible t + slime-repl-prompt t + ;; emacs stuff + rear-nonsticky (slime-repl-prompt read-only face intangible) + ;; xemacs stuff + start-open t end-open t) + (insert-before-markers prompt)) + (slime-mark-input-start) + (set-marker slime-repl-input-end-mark (point-max)) + (set-marker slime-repl-prompt-start-mark prompt-start) + (goto-char slime-repl-prompt-start-mark) + (slime-mark-output-start) + (goto-char (point-max))) + (slime-repl-show-maximum-output)) + +(defun slime-repl-show-maximum-output (&optional force) + "Put the end of the buffer at the bottom of the window." + (assert (eobp)) + (let ((win (get-buffer-window (current-buffer)))) + (when win + (with-selected-window win + (recenter -1))))) + +(defvar slime-repl-current-input-hooks) + +(defun slime-repl-current-input (&optional until-point-p) + "Return the current input as string. +The input is the region from after the last prompt to the end of +buffer." + (or (run-hook-with-args-until-success 'slime-repl-current-input-hooks + until-point-p) + (buffer-substring-no-properties + slime-repl-input-start-mark + (if (and until-point-p (<= (point) slime-repl-input-end-mark)) + (point) + slime-repl-input-end-mark)))) + +(defun slime-property-position (text-property &optional object) + "Return the first position of TEXT-PROPERTY, or nil." + (if (get-text-property 0 text-property object) + 0 + (next-single-property-change 0 text-property object))) + +(defun slime-mark-input-start () + (set-marker slime-repl-last-input-start-mark + (marker-position slime-repl-input-start-mark)) + (set-marker slime-repl-input-start-mark (point) (current-buffer)) + (set-marker slime-repl-input-end-mark (point) (current-buffer))) + +(defun slime-mark-output-start (&optional position) + (let ((position (or position (point)))) + (set-marker slime-output-start position) + (set-marker slime-output-end position))) + +(defun slime-mark-output-end () + ;; Don't put slime-repl-output-face again; it would remove the + ;; special presentation face, for instance in the SBCL inspector. + (add-text-properties slime-output-start slime-output-end + '(;;face slime-repl-output-face + rear-nonsticky (face)))) + +(defun slime-repl-bol () + "Go to the beginning of line or the prompt." + (interactive) + (cond ((and (>= (point) slime-repl-input-start-mark) + (slime-same-line-p (point) slime-repl-input-start-mark)) + (goto-char slime-repl-input-start-mark)) + (t (beginning-of-line 1))) + (slime-preserve-zmacs-region)) + +(defun slime-repl-eol () + "Go to the end of line or the prompt." + (interactive) + (if (and (<= (point) slime-repl-input-end-mark) + (slime-same-line-p (point) slime-repl-input-end-mark)) + (goto-char slime-repl-input-end-mark) + (end-of-line 1)) + (slime-preserve-zmacs-region)) + +(defun slime-preserve-zmacs-region () + "In XEmacs, ensure that the zmacs-region stays active after this command." + (when (boundp 'zmacs-region-stays) + (set 'zmacs-region-stays t))) + +(defun slime-repl-in-input-area-p () + (and (<= slime-repl-input-start-mark (point)) + (<= (point) slime-repl-input-end-mark))) + +(defun slime-repl-at-prompt-start-p () + ;; This will not work on non-current prompts. + (= (point) slime-repl-input-start-mark)) + +(defun slime-repl-beginning-of-defun () + "Move to beginning of defun." + (interactive) + ;; We call BEGINNING-OF-DEFUN if we're at the start of a prompt + ;; already, to trigger SLIME-REPL-MODE-BEGINNING-OF-DEFUN by means + ;; of the locally bound BEGINNING-OF-DEFUN-FUNCTION, in order to + ;; jump to the start of the previous prompt. + (if (and (not (slime-repl-at-prompt-start-p)) + (slime-repl-in-input-area-p)) + (goto-char slime-repl-input-start-mark) + (beginning-of-defun)) + t) + +(defun slime-repl-end-of-defun () + "Move to next of defun." + (interactive) + ;; C.f. SLIME-REPL-BEGINNING-OF-DEFUN. + (if (and (not (= (point) slime-repl-input-end-mark)) + (slime-repl-in-input-area-p)) + (goto-char slime-repl-input-end-mark) + (end-of-defun)) + t) + +;; FIXME: Shouldn't this be (= (point) slime-repl-input-end-mark)? +(defun slime-repl-at-prompt-end-p () + (and (get-char-property (max 1 (1- (point))) 'slime-repl-prompt) + (not (get-char-property (point) 'slime-repl-prompt)))) + +(defun slime-repl-find-prompt (move) + (let ((origin (point))) + (loop (funcall move) + (when (or (slime-repl-at-prompt-end-p) (bobp) (eobp)) + (return))) + (unless (slime-repl-at-prompt-end-p) + (goto-char origin)))) + +(defun slime-search-property-change-fn (prop &optional backward) + (with-lexical-bindings (prop) + (if backward + (lambda () + (goto-char + (previous-single-char-property-change (point) prop))) + (lambda () + (goto-char + (next-single-char-property-change (point) prop)))))) + +(defun slime-repl-previous-prompt () + "Move backward to the previous prompt." + (interactive) + (slime-repl-find-prompt + (slime-search-property-change-fn 'slime-repl-prompt t))) + +(defun slime-repl-next-prompt () + "Move forward to the next prompt." + (interactive) + (slime-repl-find-prompt + (slime-search-property-change-fn 'slime-repl-prompt))) + +(defvar slime-repl-return-hooks) + +(defun slime-repl-return (&optional end-of-input) + "Evaluate the current input string, or insert a newline. +Send the current input ony if a whole expression has been entered, +i.e. the parenthesis are matched. + +With prefix argument send the input even if the parenthesis are not +balanced." + (interactive "P") + (slime-check-connected) + (assert (<= (point) slime-repl-input-end-mark)) + (cond (end-of-input + (slime-repl-send-input)) + (slime-repl-read-mode ; bad style? + (slime-repl-send-input t)) + ((and (get-text-property (point) 'slime-repl-old-input) + (< (point) slime-repl-input-start-mark)) + (slime-repl-grab-old-input end-of-input) + (slime-repl-recenter-if-needed)) + ((run-hook-with-args-until-success 'slime-repl-return-hooks)) + ((slime-input-complete-p slime-repl-input-start-mark + (ecase slime-repl-return-behaviour + (:send-only-if-after-complete (min (point) slime-repl-input-end-mark)) + (:send-if-complete slime-repl-input-end-mark))) + (slime-repl-send-input t)) + (t + (slime-repl-newline-and-indent) + (message "[input not complete]")))) + +(defun slime-repl-recenter-if-needed () + "Make sure that slime-repl-input-end-mark is visible." + (unless (pos-visible-in-window-p slime-repl-input-end-mark) + (save-excursion + (goto-char slime-repl-input-end-mark) + (recenter -1)))) + +(defun slime-repl-send-input (&optional newline) + "Goto to the end of the input and send the current input. +If NEWLINE is true then add a newline at the end of the input." + (when (< (point) slime-repl-input-start-mark) + (error "No input at point.")) + (goto-char slime-repl-input-end-mark) + (let ((end (point))) ; end of input, without the newline + (slime-repl-add-to-input-history + (buffer-substring slime-repl-input-start-mark end)) + (when newline + (insert "\n") + (slime-repl-show-maximum-output)) + (let ((inhibit-read-only t)) + (add-text-properties slime-repl-input-start-mark + (point) + `(slime-repl-old-input + ,(incf slime-repl-old-input-counter)))) + (let ((overlay (make-overlay slime-repl-input-start-mark end))) + ;; These properties are on an overlay so that they won't be taken + ;; by kill/yank. + (overlay-put overlay 'read-only t) + (overlay-put overlay 'face 'slime-repl-input-face))) + (let ((input (slime-repl-current-input))) + (goto-char slime-repl-input-end-mark) + (slime-mark-input-start) + (slime-mark-output-start) + (slime-repl-send-string input))) + +(defun slime-repl-grab-old-input (replace) + "Resend the old REPL input at point. +If replace is non-nil the current input is replaced with the old +input; otherwise the new input is appended. The old input has the +text property `slime-repl-old-input'." + (multiple-value-bind (beg end) (slime-property-bounds 'slime-repl-old-input) + (let ((old-input (buffer-substring beg end)) ;;preserve + ;;properties, they will be removed later + (offset (- (point) beg))) + ;; Append the old input or replace the current input + (cond (replace (goto-char slime-repl-input-start-mark)) + (t (goto-char slime-repl-input-end-mark) + (unless (eq (char-before) ?\ ) + (insert " ")))) + (delete-region (point) slime-repl-input-end-mark) + (save-excursion (insert old-input)) + (forward-char offset)))) + +(defun slime-property-bounds (prop) + "Return two the positions of the previous and next changes to PROP. +PROP is the name of a text property." + (let* ((beg (save-excursion + ;; previous-single-char-property-change searches for a + ;; property change from the previous character, but we + ;; want to look for a change from the point. We step + ;; forward one char to avoid doing the wrong thing if + ;; we're at the beginning of the old input. -luke + ;; (18/Jun/2004) + (unless (not (get-text-property (point) prop)) + ;; alanr unless we are sitting right after it May 19, 2005 + (ignore-errors (forward-char))) + (previous-single-char-property-change (point) prop))) + (end (save-excursion + (if (get-text-property (point) prop) + (progn (goto-char (next-single-char-property-change + (point) prop)) + (skip-chars-backward "\n \t\r" beg) + (point)) + (point))))) + (values beg end))) + +(defun slime-repl-closing-return () + "Evaluate the current input string after closing all open lists." + (interactive) + (goto-char (point-max)) + (save-restriction + (narrow-to-region slime-repl-input-start-mark (point)) + (while (ignore-errors (save-excursion (backward-up-list 1)) t) + (insert ")"))) + (slime-repl-return)) + +(defun slime-repl-newline-and-indent () + "Insert a newline, then indent the next line. +Restrict the buffer from the prompt for indentation, to avoid being +confused by strange characters (like unmatched quotes) appearing +earlier in the buffer." + (interactive) + (save-restriction + (narrow-to-region slime-repl-prompt-start-mark (point-max)) + (insert "\n") + (lisp-indent-line))) + +(defun slime-repl-delete-current-input () + (delete-region slime-repl-input-start-mark slime-repl-input-end-mark)) + +(defun slime-repl-kill-input () + "Kill all text from the prompt to point." + (interactive) + (cond ((< (marker-position slime-repl-input-start-mark) (point)) + (kill-region slime-repl-input-start-mark (point))) + ((= (point) (marker-position slime-repl-input-start-mark)) + (slime-repl-delete-current-input)))) + +(defun slime-repl-replace-input (string) + (slime-repl-delete-current-input) + (insert-and-inherit string)) + +(defun slime-repl-input-line-beginning-position () + (save-excursion + (goto-char slime-repl-input-start-mark) + (line-beginning-position))) + +(defvar slime-repl-clear-buffer-hook) + +(defun slime-repl-clear-buffer () + "Delete the output generated by the Lisp process." + (interactive) + (set-marker slime-repl-last-input-start-mark nil) + (let ((inhibit-read-only t)) + (delete-region (point-min) (slime-repl-input-line-beginning-position)) + (goto-char slime-repl-input-start-mark)) + (run-hooks 'slime-repl-clear-buffer-hook)) + +(defun slime-repl-clear-output () + "Delete the output inserted since the last input." + (interactive) + (let ((start (save-excursion + (slime-repl-previous-prompt) + (ignore-errors (forward-sexp)) + (forward-line) + (point))) + (end (1- (slime-repl-input-line-beginning-position)))) + (when (< start end) + (let ((inhibit-read-only t)) + (delete-region start end) + (save-excursion + (goto-char start) + (insert ";;; output flushed")))))) + +(defun slime-indent-and-complete-symbol () + "Indent the current line and perform symbol completion. +First indent the line. If indenting doesn't move point, complete +the symbol. If there's no symbol at the point, show the arglist +for the most recently enclosed macro or function." + (interactive) + (let ((pos (point))) + (unless (get-text-property (line-beginning-position) 'slime-repl-prompt) + (lisp-indent-line)) + (when (= pos (point)) + (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t)) + (slime-complete-symbol)) + ((memq (char-before) '(?\t ?\ )) + (slime-echo-arglist)))))) + +(defun slime-repl-set-package (package) + "Set the package of the REPL buffer to PACKAGE." + (interactive (list (slime-read-package-name "Package: " + (slime-find-buffer-package)))) + (with-current-buffer (slime-output-buffer) + (let ((unfinished-input (slime-repl-current-input))) + (destructuring-bind (name prompt-string) + (slime-eval `(swank:set-package ,package)) + (setf (slime-lisp-package) name) + (setf (slime-lisp-package-prompt-string) prompt-string) + (slime-repl-insert-prompt) + (insert unfinished-input))))) + + +;;;;; History + +(defcustom slime-repl-wrap-history nil + "*T to wrap history around when the end is reached." + :type 'boolean + :group 'slime-repl) + +(make-variable-buffer-local + (defvar slime-repl-input-history '() + "History list of strings read from the REPL buffer.")) + +(defun slime-repl-add-to-input-history (string) + "Add STRING to the input history. +Empty strings and duplicates are ignored." + (unless (or (equal string "") + (equal string (car slime-repl-input-history))) + (push string slime-repl-input-history))) + +;; These two vars contain the state of the last history search. We +;; only use them if `last-command' was 'slime-repl-history-replace, +;; otherwise we reinitialize them. + +(defvar slime-repl-input-history-position -1 + "Newer items have smaller indices.") + +(defvar slime-repl-history-pattern nil + "The regexp most recently used for finding input history.") + +(defun slime-repl-history-replace (direction &optional regexp delete-at-end-p) + "Replace the current input with the next line in DIRECTION. +DIRECTION is 'forward' or 'backward' (in the history list). +If REGEXP is non-nil, only lines matching REGEXP are considered. +If DELETE-AT-END-P is non-nil then remove the string if the end of the +history is reached." + (setq slime-repl-history-pattern regexp) + (let* ((min-pos -1) + (max-pos (length slime-repl-input-history)) + (pos0 (cond ((slime-repl-history-search-in-progress-p) + slime-repl-input-history-position) + (t min-pos))) + (pos (slime-repl-position-in-history pos0 direction (or regexp ""))) + (msg nil)) + (cond ((and (< min-pos pos) (< pos max-pos)) + (slime-repl-replace-input (nth pos slime-repl-input-history)) + (setq msg (format "History item: %d" pos))) + ((not slime-repl-wrap-history) + (setq msg (cond ((= pos min-pos) "End of history") + ((= pos max-pos) "Beginning of history")))) + (slime-repl-wrap-history + (setq pos (if (= pos min-pos) max-pos min-pos)) + (setq msg "Wrapped history"))) + (when (or (<= pos min-pos) (<= max-pos pos)) + (when regexp + (setq msg (concat msg "; no matching item"))) + (when delete-at-end-p + (slime-repl-replace-input ""))) + ;;(message "%s [%d %d %s]" msg start-pos pos regexp) + (message "%s%s" msg (cond ((not regexp) "") + (t (format "; current regexp: %s" regexp)))) + (setq slime-repl-input-history-position pos) + (setq this-command 'slime-repl-history-replace))) + +(defun slime-repl-history-search-in-progress-p () + (eq last-command 'slime-repl-history-replace)) + +(defun slime-repl-terminate-history-search () + (setq last-command this-command)) + +(defun slime-repl-position-in-history (start-pos direction regexp) + "Return the position of the history item matching regexp. +Return -1 resp. the length of the history if no item matches" + ;; Loop through the history list looking for a matching line + (let* ((step (ecase direction + (forward -1) + (backward 1))) + (history slime-repl-input-history) + (len (length history))) + (loop for pos = (+ start-pos step) then (+ pos step) + if (< pos 0) return -1 + if (<= len pos) return len + if (string-match regexp (nth pos history)) return pos))) + +(defun slime-repl-previous-input () + "Cycle backwards through input history. +If the `last-command' was a history navigation command use the +same search pattern for this command. +Otherwise use the current input as search pattern." + (interactive) + (slime-repl-history-replace 'backward (slime-repl-history-pattern t) t)) + +(defun slime-repl-next-input () + "Cycle forwards through input history. +See `slime-repl-previous-input'." + (interactive) + (slime-repl-history-replace 'forward (slime-repl-history-pattern t) t)) + +(defun slime-repl-forward-input () + "Cycle forwards through input history." + (interactive) + (slime-repl-history-replace 'forward (slime-repl-history-pattern) t)) + +(defun slime-repl-backward-input () + "Cycle backwards through input history." + (interactive) + (slime-repl-history-replace 'backward (slime-repl-history-pattern) t)) + +(defun slime-repl-previous-matching-input (regexp) + (interactive "sPrevious element matching (regexp): ") + (slime-repl-terminate-history-search) + (slime-repl-history-replace 'backward regexp)) + +(defun slime-repl-next-matching-input (regexp) + (interactive "sNext element matching (regexp): ") + (slime-repl-terminate-history-search) + (slime-repl-history-replace 'forward regexp)) + +(defun slime-repl-history-pattern (&optional use-current-input) + "Return the regexp for the navigation commands." + (cond ((slime-repl-history-search-in-progress-p) + slime-repl-history-pattern) + (use-current-input + (let ((str (slime-repl-current-input))) + (cond ((string-match "^[ \n]*$" str) nil) + (t (concat "^" (regexp-quote str)))))) + (t nil))) + +(defun slime-repl-delete-from-input-history (string) + "Delete STRING from the repl input history. + +When string is not provided then clear the current repl input and +use it as an input. This is useful to get rid of unwanted repl +history entries while navigating the repl history." + (interactive (list (slime-repl-current-input))) + (let ((merged-history + (slime-repl-merge-histories slime-repl-input-history + (slime-repl-read-history nil t)))) + (setq slime-repl-input-history + (delete* string merged-history :test #'string=)) + (slime-repl-save-history)) + (slime-repl-delete-current-input)) + +;;;;; Persistent History + +(defun slime-repl-merge-histories (old-hist new-hist) + "Merge entries from OLD-HIST and NEW-HIST." + ;; Newer items in each list are at the beginning. + (let* ((ht (make-hash-table :test #'equal)) + (test (lambda (entry) + (or (gethash entry ht) + (progn (setf (gethash entry ht) t) + nil))))) + (append (remove-if test new-hist) + (remove-if test old-hist)))) + +(defun slime-repl-load-history (&optional filename) + "Set the current SLIME REPL history. +It can be read either from FILENAME or `slime-repl-history-file' or +from a user defined filename." + (interactive (list (slime-repl-read-history-filename))) + (let ((file (or filename slime-repl-history-file))) + (setq slime-repl-input-history (slime-repl-read-history file t)))) + +(defun slime-repl-read-history (&optional filename noerrer) + "Read and return the history from FILENAME. +The default value for FILENAME is `slime-repl-history-file'. +If NOERROR is true return and the file doesn't exits return nil." + (let ((file (or filename slime-repl-history-file))) + (cond ((not (file-readable-p file)) '()) + (t (with-temp-buffer + (insert-file-contents file) + (read (current-buffer))))))) + +(defun slime-repl-read-history-filename () + (read-file-name "Use SLIME REPL history from file: " + slime-repl-history-file)) + +(defun slime-repl-save-merged-history (&optional filename) + "Read the history file, merge the current REPL history and save it. +This tries to be smart in merging the history from the file and the +current history in that it tries to detect the unique entries using +`slime-repl-merge-histories'." + (interactive (list (slime-repl-read-history-filename))) + (let ((file (or filename slime-repl-history-file))) + (with-temp-message "saving history..." + (let ((hist (slime-repl-merge-histories (slime-repl-read-history file t) + slime-repl-input-history))) + (slime-repl-save-history file hist))))) + +(defun slime-repl-save-history (&optional filename history) + "Simply save the current SLIME REPL history to a file. +When SLIME is setup to always load the old history and one uses only +one instance of slime all the time, there is no need to merge the +files and this function is sufficient. + +When the list is longer than `slime-repl-history-size' it will be +truncated. That part is untested, though!" + (interactive (list (slime-repl-read-history-filename))) + (let ((file (or filename slime-repl-history-file)) + (hist (or history slime-repl-input-history))) + (unless (file-writable-p file) + (error (format "History file not writable: %s" file))) + (let ((hist (subseq hist 0 (min (length hist) slime-repl-history-size)))) + ;;(message "saving %s to %s\n" hist file) + (with-temp-file file + (let ((cs slime-repl-history-file-coding-system) + (print-length nil) (print-level nil)) + (setq buffer-file-coding-system cs) + (insert (format ";; -*- coding: %s -*-\n" cs)) + (insert ";; History for SLIME REPL. Automatically written.\n" + ";; Edit only if you know what you're doing\n") + (prin1 (mapcar #'substring-no-properties hist) (current-buffer))))))) + +(defun slime-repl-save-all-histories () + "Save the history in each repl buffer." + (dolist (b (buffer-list)) + (with-current-buffer b + (when (eq major-mode 'slime-repl-mode) + (slime-repl-safe-save-merged-history))))) + +(defun slime-repl-safe-save-merged-history () + (slime-repl-call-with-handler + #'slime-repl-save-merged-history + "%S while saving the history. Continue? ")) + +(defun slime-repl-safe-load-history () + (slime-repl-call-with-handler + #'slime-repl-load-history + "%S while loading the history. Continue? ")) + +(defun slime-repl-call-with-handler (fun query) + "Call FUN in the context of an error handler. +The handler will use qeuery to ask the use if the error should be ingored." + (condition-case err + (funcall fun) + (error + (if (y-or-n-p (format query (error-message-string err))) + nil + (signal (car err) (cdr err)))))) + + +;;;;; REPL Read Mode + +(define-key slime-repl-mode-map + (string slime-repl-shortcut-dispatch-char) 'slime-handle-repl-shortcut) + +(define-minor-mode slime-repl-read-mode + "Mode the read input from Emacs +\\{slime-repl-read-mode-map}" + nil + "[read]" + '(("\C-m" . slime-repl-return) + ("\C-c\C-b" . slime-repl-read-break) + ("\C-c\C-c" . slime-repl-read-break))) + +(make-variable-buffer-local + (defvar slime-read-string-threads nil)) + +(make-variable-buffer-local + (defvar slime-read-string-tags nil)) + +(defun slime-repl-read-string (thread tag) + (slime-switch-to-output-buffer) + (push thread slime-read-string-threads) + (push tag slime-read-string-tags) + (goto-char (point-max)) + (slime-mark-output-end) + (slime-mark-input-start) + (slime-repl-read-mode 1)) + +(defun slime-y-or-n-p (thread tag question) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,(y-or-n-p question)))) + +(defun slime-repl-return-string (string) + (slime-dispatch-event `(:emacs-return-string + ,(pop slime-read-string-threads) + ,(pop slime-read-string-tags) + ,string)) + (slime-repl-read-mode -1)) + +(defun slime-repl-read-break () + (interactive) + (slime-dispatch-event `(:emacs-interrupt ,(car slime-read-string-threads)))) + +(defun slime-repl-abort-read (thread tag) + (with-current-buffer (slime-output-buffer) + (pop slime-read-string-threads) + (pop slime-read-string-tags) + (slime-repl-read-mode -1) + (message "Read aborted"))) + + +;;;;; REPL handlers + +(defstruct (slime-repl-shortcut (:conc-name slime-repl-shortcut.)) + symbol names handler one-liner) + +(defvar slime-repl-shortcut-table nil + "A list of slime-repl-shortcuts") + +(defvar slime-repl-shortcut-history '() + "History list of shortcut command names.") + +(defun slime-handle-repl-shortcut () + (interactive) + (if (> (point) slime-repl-input-start-mark) + (insert (string slime-repl-shortcut-dispatch-char)) + (let ((shortcut (slime-lookup-shortcut + (completing-read "Command: " + (slime-bogus-completion-alist + (slime-list-all-repl-shortcuts)) + nil t nil + 'slime-repl-shortcut-history)))) + (call-interactively (slime-repl-shortcut.handler shortcut))))) + +(defun slime-list-all-repl-shortcuts () + (loop for shortcut in slime-repl-shortcut-table + append (slime-repl-shortcut.names shortcut))) + +(defun slime-lookup-shortcut (name) + (find-if (lambda (s) (member name (slime-repl-shortcut.names s))) + slime-repl-shortcut-table)) + +(defmacro defslime-repl-shortcut (elisp-name names &rest options) + "Define a new repl shortcut. ELISP-NAME is a symbol specifying + the name of the interactive function to create, or NIL if no + function should be created. NAMES is a list of (full-name . + aliases). OPTIONS is an olist specifying the handler and the + help text." + `(progn + ,(when elisp-name + `(defun ,elisp-name () + (interactive) + (call-interactively ,(second (assoc :handler options))))) + (let ((new-shortcut (make-slime-repl-shortcut + :symbol ',elisp-name + :names (list ,@names) + ,@(apply #'append options)))) + (setq slime-repl-shortcut-table + (remove-if (lambda (s) + (member ',(car names) (slime-repl-shortcut.names s))) + slime-repl-shortcut-table)) + (push new-shortcut slime-repl-shortcut-table) + ',elisp-name))) + +(defun slime-list-repl-short-cuts () + (interactive) + (slime-with-output-to-temp-buffer ("*slime-repl-help*") nil + (let ((table (sort* (copy-list slime-repl-shortcut-table) #'string< + :key (lambda (x) + (car (slime-repl-shortcut.names x)))))) + (dolist (shortcut table) + (let ((names (slime-repl-shortcut.names shortcut))) + (insert (pop names)) ;; first print the "full" name + (when names + ;; we also have aliases + (insert " (aka ") + (while (cdr names) + (insert (pop names) ", ")) + (insert (car names) ")")) + (insert "\n " (slime-repl-shortcut.one-liner shortcut) + "\n")))))) + +(defun slime-save-some-lisp-buffers () + (if slime-repl-only-save-lisp-buffers + (save-some-buffers nil (lambda () + (and (memq major-mode slime-lisp-modes) + (not (null buffer-file-name))))) + (save-some-buffers))) + +(defslime-repl-shortcut slime-repl-shortcut-help ("help" "?") + (:handler 'slime-list-repl-short-cuts) + (:one-liner "Display the help.")) + +(defslime-repl-shortcut nil ("change-directory" "!d" "cd") + (:handler 'slime-set-default-directory) + (:one-liner "Change the current directory.")) + +(defslime-repl-shortcut nil ("pwd") + (:handler (lambda () + (interactive) + (let ((dir (slime-eval `(swank:default-directory)))) + (message "Directory %s" dir)))) + (:one-liner "Show the current directory.")) + +(defslime-repl-shortcut slime-repl-push-directory + ("push-directory" "+d" "pushd") + (:handler (lambda (directory) + (interactive + (list (read-directory-name + "Push directory: " + (slime-eval '(swank:default-directory)) + nil nil ""))) + (push (slime-eval '(swank:default-directory)) + slime-repl-directory-stack) + (slime-set-default-directory directory))) + (:one-liner "Save the current directory and set it to a new one.")) + +(defslime-repl-shortcut slime-repl-pop-directory + ("pop-directory" "-d" "popd") + (:handler (lambda () + (interactive) + (if (null slime-repl-directory-stack) + (message "Directory stack is empty.") + (slime-set-default-directory + (pop slime-repl-directory-stack))))) + (:one-liner "Restore the last saved directory.")) + +(defslime-repl-shortcut nil ("change-package" "!p" "in-package" "in") + (:handler 'slime-repl-set-package) + (:one-liner "Change the current package.")) + +(defslime-repl-shortcut slime-repl-push-package ("push-package" "+p") + (:handler (lambda (package) + (interactive (list (slime-read-package-name "Package: "))) + (push (slime-lisp-package) slime-repl-package-stack) + (slime-repl-set-package package))) + (:one-liner "Save the current package and set it to a new one.")) + +(defslime-repl-shortcut slime-repl-pop-package ("pop-package" "-p") + (:handler (lambda () + (interactive) + (if (null slime-repl-package-stack) + (message "Package stack is empty.") + (slime-repl-set-package + (pop slime-repl-package-stack))))) + (:one-liner "Restore the last saved package.")) + +(defslime-repl-shortcut slime-repl-resend ("resend-form") + (:handler (lambda () + (interactive) + (insert (car slime-repl-input-history)) + (insert "\n") + (slime-repl-send-input))) + (:one-liner "Resend the last form.")) + +(defslime-repl-shortcut slime-repl-disconnect ("disconnect") + (:handler 'slime-disconnect) + (:one-liner "Disconnect all connections.")) + +(defslime-repl-shortcut slime-repl-sayoonara ("sayoonara") + (:handler (lambda () + (interactive) + (when (slime-connected-p) + (slime-quit-lisp)) + (slime-kill-all-buffers))) + (:one-liner "Quit all Lisps and close all SLIME buffers.")) + +(defslime-repl-shortcut slime-repl-quit ("quit") + (:handler 'slime-quit-lisp) + (:one-liner "Quit the current Lisp.")) + +(defslime-repl-shortcut slime-repl-defparameter ("defparameter" "!") + (:handler (lambda (name value) + (interactive (list (slime-read-symbol-name "Name (symbol): " t) + (slime-read-from-minibuffer "Value: " "*"))) + (insert "(cl:defparameter " name " " value + " \"REPL generated global variable.\")") + (slime-repl-send-input t))) + (:one-liner "Define a new global, special, variable.")) + +(defslime-repl-shortcut slime-repl-compile-and-load ("compile-and-load" "cl") + (:handler (lambda (filename) + (interactive (list (expand-file-name + (read-file-name "File: " nil nil nil nil)))) + (slime-save-some-lisp-buffers) + (slime-eval-async + `(swank:compile-file-if-needed + ,(slime-to-lisp-filename filename) t) + (slime-make-compilation-finished-continuation (current-buffer))))) + (:one-liner "Compile (if neccessary) and load a lisp file.")) + +(defslime-repl-shortcut nil ("restart-inferior-lisp") + (:handler 'slime-restart-inferior-lisp) + (:one-liner "Restart *inferior-lisp* and reconnect SLIME.")) + +(defun slime-restart-inferior-lisp () + (interactive) + (assert (slime-inferior-process) () "No inferior lisp process") + (slime-eval-async '(swank:quit-lisp)) + (set-process-filter (slime-connection) nil) + (set-process-sentinel (slime-connection) 'slime-restart-sentinel)) + +(defun slime-restart-sentinel (process message) + "Restart the inferior lisp process. +Also rearrange windows." + (assert (process-status process) 'closed) + (let* ((proc (slime-inferior-process process)) + (args (slime-inferior-lisp-args proc)) + (buffer (buffer-name (process-buffer proc))) + (buffer-window (get-buffer-window buffer)) + (new-proc (slime-start-lisp (plist-get args :program) + (plist-get args :program-args) + nil + buffer)) + (repl-buffer (slime-repl-buffer nil process)) + (repl-window (and repl-buffer (get-buffer-window repl-buffer)))) + (slime-net-close process) + (slime-inferior-connect new-proc args) + (cond ((and repl-window (not buffer-window)) + (set-window-buffer repl-window buffer) + (select-window repl-window)) + (repl-window + (select-window repl-window)) + (t + (pop-to-buffer buffer))) + (switch-to-buffer buffer) + (goto-char (point-max)))) + + +;;;;; Cleanup after a quit + +(defun slime-kill-all-buffers () + "Kill all the slime related buffers. This is only used by the + repl command sayoonara." + (dolist (buf (buffer-list)) + (when (or (string= (buffer-name buf) slime-event-buffer-name) + (string-match "^\\*inferior-lisp*" (buffer-name buf)) + (string-match "^\\*slime-repl .*\\*$" (buffer-name buf)) + (string-match "^\\*sldb .*\\*$" (buffer-name buf)) + (string-match "^\\*SLIME.*\\*$" (buffer-name buf))) + (kill-buffer buf)))) + + +;;;; Compilation and the creation of compiler-note annotations + +(defvar slime-highlight-compiler-notes t + "*When non-nil annotate buffers with compilation notes etc.") + +(defcustom slime-display-compilation-output t + "Display the REPL buffer before compiling files." + :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) + :group 'slime-mode) + +(defvar slime-before-compile-functions nil + "A list of function called before compiling a buffer or region. +The function receive two arguments: the beginning and the end of the +region that will be compiled.") + +(defcustom slime-compilation-finished-hook 'slime-maybe-list-compiler-notes + "Hook called with a list of compiler notes after a compilation." + :group 'slime-mode + :type 'hook + :options '(slime-maybe-list-compiler-notes + slime-list-compiler-notes + slime-maybe-show-xrefs-for-notes)) + +(defcustom slime-goto-first-note-after-compilation nil + "When T next-note will always goto to the first note in a +final, no matter where the point is." + :group 'slime-mode + :type 'boolean) + +(defun slime-compile-and-load-file () + "Compile and load the buffer's file and highlight compiler notes. + +Each source location that is the subject of a compiler note is +underlined and annotated with the relevant information. The commands +`slime-next-note' and `slime-previous-note' can be used to navigate +between compiler notes and to display their full details." + (interactive) + (slime-compile-file t)) + +(defun slime-compile-file (&optional load) + "Compile current buffer's file and highlight resulting compiler notes. + +See `slime-compile-and-load-file' for further details." + (interactive) + ;;(unless (memq major-mode slime-lisp-modes) + ;; (error "Only valid in lisp-mode")) + (check-parens) + (unless buffer-file-name + (error "Buffer %s is not associated with a file." (buffer-name))) + (when (and (buffer-modified-p) + (y-or-n-p (format "Save file %s? " (buffer-file-name)))) + (save-buffer)) + (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max)) + (let ((file (slime-to-lisp-filename (buffer-file-name)))) + (slime-insert-transcript-delimiter (format "Compile file %s" file)) + (when slime-display-compilation-output + (slime-display-output-buffer)) + (slime-eval-async + `(swank:compile-file-for-emacs ,file ,(if load t nil)) + (slime-rcurry #'slime-compilation-finished (current-buffer))) + (message "Compiling %s..." file))) + +(defun slime-compile-defun () + "Compile the current toplevel form." + (interactive) + (apply #'slime-compile-region (slime-region-for-defun-at-point))) + +(defun slime-compile-region (start end) + "Compile the region." + (interactive "r") + (run-hook-with-args 'slime-before-compile-functions start end) + (slime-compile-string (buffer-substring-no-properties start end) start)) + +(defun slime-compile-string (string start-offset) + (slime-eval-async + `(swank:compile-string-for-emacs + ,string + ,(buffer-name) + ,start-offset + ,(if (buffer-file-name) (file-name-directory (buffer-file-name)))) + (slime-make-compilation-finished-continuation (current-buffer)))) + +(defun slime-note-count-string (severity count &optional suppress-if-zero) + (cond ((and (zerop count) suppress-if-zero) + "") + (t (format "%2d %s%s " count severity (if (= count 1) "" "s"))))) + +(defun slime-show-note-counts (notes &optional secs) + (let ((nerrors 0) (nwarnings 0) (nstyle-warnings 0) (nnotes 0)) + (dolist (note notes) + (ecase (slime-note.severity note) + ((:error :read-error) (incf nerrors)) + (:warning (incf nwarnings)) + (:style-warning (incf nstyle-warnings)) + (:note (incf nnotes)))) + (message "Compilation finished:%s%s%s%s%s" + (slime-note-count-string "error" nerrors) + (slime-note-count-string "warning" nwarnings) + (slime-note-count-string "style-warning" nstyle-warnings t) + (slime-note-count-string "note" nnotes) + (if secs (format "[%s secs]" secs) "")))) + +(defun slime-xrefs-for-notes (notes) + (let ((xrefs)) + (dolist (note notes) + (let* ((location (getf note :location)) + (fn (cadr (assq :file (cdr location)))) + (file (assoc fn xrefs)) + (node + (cons (format "%s: %s" + (getf note :severity) + (slime-one-line-ify (getf note :message))) + location))) + (when fn + (if file + (push node (cdr file)) + (setf xrefs (acons fn (list node) xrefs)))))) + xrefs)) + +(defun slime-one-line-ify (string) + "Return a single-line version of STRING. +Each newlines and following indentation is replaced by a single space." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "\n[\n \t]*" nil t) + (replace-match " ")) + (buffer-string))) + +(defun slime-compilation-finished (result buffer &optional emacs-snapshot) + (let ((notes (slime-compiler-notes))) + (with-current-buffer buffer + (setf slime-compilation-just-finished t) + (destructuring-bind (result secs) result + (slime-show-note-counts notes secs) + (when slime-highlight-compiler-notes + (slime-highlight-notes notes)))) + (run-hook-with-args 'slime-compilation-finished-hook notes emacs-snapshot))) + +(defun slime-make-compilation-finished-continuation (current-buffer &optional emacs-snapshot) + (lexical-let ((buffer current-buffer) (snapshot emacs-snapshot)) + (lambda (result) + (slime-compilation-finished result buffer snapshot)))) + +(defun slime-highlight-notes (notes) + "Highlight compiler notes, warnings, and errors in the buffer." + (interactive (list (slime-compiler-notes))) + (with-temp-message "Highlighting notes..." + (save-excursion + (save-restriction + (widen) ; highlight notes on the whole buffer + (slime-remove-old-overlays) + (mapc #'slime-overlay-note (slime-merge-notes-for-display notes)))))) + +(defun slime-compiler-notes () + "Return all compiler notes, warnings, and errors." + (slime-eval `(swank:compiler-notes-for-emacs))) + +(defun slime-remove-old-overlays () + "Delete the existing Slime overlays in the current buffer." + (dolist (buffer (slime-filter-buffers (lambda () slime-mode))) + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) ; remove overlays within the whole buffer. + (goto-char (point-min)) + (while (not (eobp)) + (dolist (o (overlays-at (point))) + (when (overlay-get o 'slime) + (delete-overlay o))) + (goto-char (next-overlay-change (point))))))))) + +(defun slime-filter-buffers (predicate) + "Return a list of where PREDICATE returns true. +PREDICATE is executed in the buffer to test." + (remove-if-not (lambda (%buffer) + (with-current-buffer %buffer + (funcall predicate))) + (buffer-list))) + + +;;;;; Merging together compiler notes in the same location. + +(defun slime-merge-notes-for-display (notes) + "Merge together notes that refer to the same location. +This operation is \"lossy\" in the broad sense but not for display purposes." + (mapcar #'slime-merge-notes + (slime-group-similar 'slime-notes-in-same-location-p notes))) + +(defun slime-merge-notes (notes) + "Merge NOTES together. Keep the highest severity, concatenate the messages." + (let* ((new-severity (reduce #'slime-most-severe notes + :key #'slime-note.severity)) + (new-message (mapconcat #'slime-note.short-message notes "\n"))) + (let ((new-note (copy-list (car notes)))) + (setf (getf new-note :message) new-message) + (setf (getf new-note :severity) new-severity) + new-note))) + +;; XXX: unused function +(defun slime-intersperse (element list) + "Intersperse ELEMENT between each element of LIST." + (if (null list) + '() + (cons (car list) + (mapcan (lambda (x) (list element x)) (cdr list))))) + +(defun slime-notes-in-same-location-p (a b) + (equal (slime-note.location a) (slime-note.location b))) + +(defun slime-group-similar (similar-p list) + "Return the list of lists of 'similar' adjacent elements of LIST. +The function SIMILAR-P is used to test for similarity. +The order of the input list is preserved." + (if (null list) + nil + (let ((accumulator (list (list (car list))))) + (dolist (x (cdr list)) + (if (funcall similar-p x (caar accumulator)) + (push x (car accumulator)) + (push (list x) accumulator))) + (reverse (mapcar #'reverse accumulator))))) + + +;;;;; Compiler notes list + +(defun slime-maybe-show-xrefs-for-notes (&optional notes emacs-snapshot) + "Show the compiler notes NOTES if they come from more than one file." + (let* ((notes (or notes (slime-compiler-notes))) + (xrefs (slime-xrefs-for-notes notes))) + (when (slime-length> xrefs 1) ; >1 file + (slime-show-xrefs + xrefs 'definition "Compiler notes" (slime-current-package) + emacs-snapshot)))) + +(defun slime-note-has-location-p (note) + (not (eq ':error (car (slime-note.location note))))) + +(defun slime-maybe-list-compiler-notes (notes &optional emacs-snapshot) + "Show the compiler notes if appropriate." + ;; don't pop up a buffer if all notes are already annotated in the + ;; buffer itself + (unless (every #'slime-note-has-location-p notes) + (slime-list-compiler-notes notes emacs-snapshot))) + +(defun slime-list-compiler-notes (notes &optional emacs-snapshot) + "Show the compiler notes NOTES in tree view." + (interactive (list (slime-compiler-notes))) + (with-temp-message "Preparing compiler note tree..." + (with-current-buffer + (slime-get-temp-buffer-create "*compiler notes*" + :mode 'slime-compiler-notes-mode + :emacs-snapshot emacs-snapshot) + (let ((inhibit-read-only t)) + (erase-buffer) + (when (null notes) + (insert "[no notes]")) + (dolist (tree (slime-compiler-notes-to-tree notes)) + (slime-tree-insert tree "") + (insert "\n"))) + (setq buffer-read-only t) + (goto-char (point-min))))) + +(defun slime-alistify (list key test) + "Partition the elements of LIST into an alist. +KEY extracts the key from an element and TEST is used to compare keys." + (declare (type function key)) + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (assoc* k alist :test test))) + (if probe + (push e (cdr probe)) + (push (cons k (list e)) alist)))) + ;; Put them back in order. + (loop for (key . value) in alist + collect (cons key (reverse value))))) + +(defun slime-note.severity (note) + (plist-get note :severity)) + +(defun slime-note.message (note) + (plist-get note :message)) + +(defun slime-note.short-message (note) + (or (plist-get note :short-message) + (plist-get note :message))) + +(defun slime-note.location (note) + (plist-get note :location)) + +(defun slime-severity-label (severity) + (ecase severity + (:note "Notes") + (:warning "Warnings") + (:error "Errors") + (:read-error "Read Errors") + (:style-warning "Style Warnings"))) + +(defvar slime-tree-printer 'slime-tree-default-printer) + +(defun slime-tree-for-note (note) + (make-slime-tree :item (slime-note.message note) + :plist (list 'note note) + :print-fn slime-tree-printer)) + +(defun slime-tree-for-severity (severity notes collapsed-p) + (make-slime-tree :item (format "%s (%d)" + (slime-severity-label severity) + (length notes)) + :kids (mapcar #'slime-tree-for-note notes) + :collapsed-p collapsed-p)) + +(defun slime-compiler-notes-to-tree (notes) + (let* ((alist (slime-alistify notes #'slime-note.severity #'eq)) + (collapsed-p (slime-length> alist 1))) + (loop for (severity . notes) in alist + collect (slime-tree-for-severity severity notes + collapsed-p)))) + +(defvar slime-compiler-notes-mode-map) + +(define-derived-mode slime-compiler-notes-mode fundamental-mode + "Compiler Notes" + "\\<slime-compiler-notes-mode-map>\ +\\{slime-compiler-notes-mode-map}" + (slime-set-truncate-lines)) + +(slime-define-keys slime-compiler-notes-mode-map + ((kbd "RET") 'slime-compiler-notes-default-action-or-show-details) + ([mouse-2] 'slime-compiler-notes-default-action-or-show-details/mouse) + ("q" 'slime-temp-buffer-quit)) + +(defun slime-compiler-notes-default-action-or-show-details/mouse (event) + "Invoke the action pointed at by the mouse, or show details." + (interactive "e") + (destructuring-bind (mouse-2 (w pos &rest _) &rest __) event + (save-excursion + (goto-char pos) + (let ((fn (get-text-property (point) + 'slime-compiler-notes-default-action))) + (if fn (funcall fn) (slime-compiler-notes-show-details)))))) + +(defun slime-compiler-notes-default-action-or-show-details () + "Invoke the action at point, or show details." + (interactive) + (let ((fn (get-text-property (point) 'slime-compiler-notes-default-action))) + (if fn (funcall fn) (slime-compiler-notes-show-details)))) + +(defun slime-compiler-notes-show-details () + (interactive) + (let* ((tree (slime-tree-at-point)) + (note (plist-get (slime-tree.plist tree) 'note)) + (inhibit-read-only t)) + (cond ((not (slime-tree-leaf-p tree)) + (slime-tree-toggle tree)) + (t + (slime-show-source-location (slime-note.location note) t))))) + + +;;;;;; Tree Widget + +(defstruct (slime-tree (:conc-name slime-tree.)) + item + (print-fn #'slime-tree-default-printer :type function) + (kids '() :type list) + (collapsed-p t :type boolean) + (prefix "" :type string) + (start-mark nil) + (end-mark nil) + (plist '() :type list)) + +(defun slime-tree-leaf-p (tree) + (not (slime-tree.kids tree))) + +(defun slime-tree-default-printer (tree) + (princ (slime-tree.item tree) (current-buffer))) + +(defun slime-tree-decoration (tree) + (cond ((slime-tree-leaf-p tree) "-- ") + ((slime-tree.collapsed-p tree) "[+] ") + (t "-+ "))) + +(defun slime-tree-insert-list (list prefix) + "Insert a list of trees." + (loop for (elt . rest) on list + do (cond (rest + (insert prefix " |") + (slime-tree-insert elt (concat prefix " |")) + (insert "\n")) + (t + (insert prefix " `") + (slime-tree-insert elt (concat prefix " ")))))) + +(defun slime-tree-insert-decoration (tree) + (insert (slime-tree-decoration tree))) + +(defun slime-tree-indent-item (start end prefix) + "Insert PREFIX at the beginning of each but the first line. +This is used for labels spanning multiple lines." + (save-excursion + (goto-char end) + (beginning-of-line) + (while (< start (point)) + (insert-before-markers prefix) + (forward-line -1)))) + +(defun slime-tree-insert (tree prefix) + "Insert TREE prefixed with PREFIX at point." + (with-struct (slime-tree. print-fn kids collapsed-p start-mark end-mark) tree + (let ((line-start (line-beginning-position))) + (setf start-mark (point-marker)) + (slime-tree-insert-decoration tree) + (funcall print-fn tree) + (slime-tree-indent-item start-mark (point) (concat prefix " ")) + (add-text-properties line-start (point) (list 'slime-tree tree)) + (set-marker-insertion-type start-mark t) + (when (and kids (not collapsed-p)) + (terpri (current-buffer)) + (slime-tree-insert-list kids prefix)) + (setf (slime-tree.prefix tree) prefix) + (setf end-mark (point-marker))))) + +(defun slime-tree-at-point () + (cond ((get-text-property (point) 'slime-tree)) + (t (error "No tree at point")))) + +(defun slime-tree-delete (tree) + "Delete the region for TREE." + (delete-region (slime-tree.start-mark tree) + (slime-tree.end-mark tree))) + +(defun slime-tree-toggle (tree) + "Toggle the visibility of TREE's children." + (with-struct (slime-tree. collapsed-p start-mark end-mark prefix) tree + (setf collapsed-p (not collapsed-p)) + (slime-tree-delete tree) + (insert-before-markers " ") ; move parent's end-mark + (backward-char 1) + (slime-tree-insert tree prefix) + (delete-char 1) + (goto-char start-mark))) + + +;;;;; Adding a single compiler note + +(defun slime-overlay-note (note) + "Add a compiler note to the buffer as an overlay. +If an appropriate overlay for a compiler note in the same location +already exists then the new information is merged into it. Otherwise a +new overlay is created." + (multiple-value-bind (start end) (slime-choose-overlay-region note) + (when start + (goto-char start) + (let ((severity (plist-get note :severity)) + (message (plist-get note :message)) + (overlay (slime-note-at-point))) + (if overlay + (slime-merge-note-into-overlay overlay severity message) + (slime-create-note-overlay note start end severity message)))))) + +(defun slime-create-note-overlay (note start end severity message) + "Create an overlay representing a compiler note. +The overlay has several properties: + FACE - to underline the relevant text. + SEVERITY - for future reference, :NOTE, :STYLE-WARNING, :WARNING, or :ERROR. + MOUSE-FACE - highlight the note when the mouse passes over. + HELP-ECHO - a string describing the note, both for future reference + and for display as a tooltip (due to the special + property name)." + (let ((overlay (make-overlay start end))) + (flet ((putp (name value) (overlay-put overlay name value))) + (putp 'slime note) + (putp 'face (slime-severity-face severity)) + (putp 'severity severity) + (unless (slime-emacs-20-p) + (putp 'mouse-face 'highlight)) + (putp 'help-echo message) + overlay))) + +;; XXX Obsolete due to `slime-merge-notes-for-display' doing the +;; work already -- unless we decide to put several sets of notes on a +;; buffer without clearing in between, which only this handles. +(defun slime-merge-note-into-overlay (overlay severity message) + "Merge another compiler note into an existing overlay. +The help text describes both notes, and the highest of the severities +is kept." + (flet ((putp (name value) (overlay-put overlay name value)) + (getp (name) (overlay-get overlay name))) + (putp 'severity (slime-most-severe severity (getp 'severity))) + (putp 'face (slime-severity-face (getp 'severity))) + (putp 'help-echo (concat (getp 'help-echo) "\n" message)))) + +(defun slime-choose-overlay-region (note) + "Choose the start and end points for an overlay over NOTE. +If the location's sexp is a list spanning multiple lines, then the +region around the first element is used. +Return nil if there's no useful source location." + (let ((location (slime-note.location note))) + (when location + (destructure-case location + ((:error _) _ nil) ; do nothing + ((:location file pos _hints) + (cond ((eq (car file) ':source-form) nil) + (t + (destructure-case pos + ((:position pos &optional alignp) + (if (eq (slime-note.severity note) :read-error) + (values pos (1+ pos)) + (slime-choose-overlay-for-sexp location))) + (t + (slime-choose-overlay-for-sexp location)))))))))) + +(defun slime-choose-overlay-for-sexp (location) + (slime-goto-source-location location) + (skip-chars-forward "'#`") + (let ((start (point))) + (ignore-errors (slime-forward-sexp)) + (if (slime-same-line-p start (point)) + (values start (point)) + (values (1+ start) + (progn (goto-char (1+ start)) + (ignore-errors (forward-sexp 1)) + (point)))))) + +(defun slime-same-line-p (pos1 pos2) + "Return t if buffer positions POS1 and POS2 are on the same line." + (save-excursion (goto-char (min pos1 pos2)) + (<= (max pos1 pos2) (line-end-position)))) + +(defun slime-severity-face (severity) + "Return the name of the font-lock face representing SEVERITY." + (ecase severity + (:error 'slime-error-face) + (:read-error 'slime-error-face) + (:warning 'slime-warning-face) + (:style-warning 'slime-style-warning-face) + (:note 'slime-note-face))) + +(defun slime-most-severe (sev1 sev2) + "Return the most servere of two conditions. +Severity is ordered as :NOTE < :STYLE-WARNING < :WARNING < :ERROR." + ; Well, not exactly Smullyan.. + (let ((order '(:note :style-warning :warning :error :read-error))) + (if (>= (position sev1 order) + (position sev2 order)) + sev1 + sev2))) + +;; XXX: unused function +(defun slime-visit-source-path (source-path) + "Visit a full source path including the top-level form." + (goto-char (point-min)) + (slime-forward-source-path source-path)) + +(defun slime-forward-positioned-source-path (source-path) + "Move forward through a sourcepath from a fixed position. +The point is assumed to already be at the outermost sexp, making the +first element of the source-path redundant." + (ignore-errors + (slime-forward-sexp) + (beginning-of-defun)) + (when-let (source-path (cdr source-path)) + (down-list 1) + (slime-forward-source-path source-path))) + +(defun slime-forward-source-path (source-path) + (let ((origin (point))) + (condition-case nil + (progn + (loop for (count . more) on source-path + do (progn + (slime-forward-sexp count) + (when more (down-list 1)))) + ;; Align at beginning + (slime-forward-sexp) + (beginning-of-sexp)) + (error (goto-char origin))))) + +(defun slime-filesystem-toplevel-directory () + ;; Windows doesn't have a true toplevel root directory, and all + ;; filenames look like "c:/foo/bar/quux.baz" from an Emacs + ;; perspective anyway. + (if (memq system-type '(ms-dos windows-nt)) + "" + (file-name-as-directory "/"))) + +(defun slime-file-name-merge-source-root (target-filename buffer-filename) + "Returns a filename where the source root directory of TARGET-FILENAME +is replaced with the source root directory of BUFFER-FILENAME. + +If no common source root could be determined, return NIL. + +E.g. (slime-file-name-merge-source-root + \"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\" + \"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\") + + ==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\" +" + (let ((target-dirs (slime-split-string (file-name-directory target-filename) "/" t)) + (buffer-dirs (slime-split-string (file-name-directory buffer-filename) "/" t))) + ;; Starting from the end, we look if one of the TARGET-DIRS exists + ;; in BUFFER-FILENAME---if so, it and everything left from that dirname + ;; is considered to be the source root directory of BUFFER-FILENAME. + (loop with target-suffix-dirs = nil + with buffer-dirs* = (reverse buffer-dirs) + with target-dirs* = (reverse target-dirs) + for target-dir in target-dirs* + do (flet ((concat-dirs (dirs) + (apply #'concat (mapcar #'file-name-as-directory dirs)))) + (let ((pos (position target-dir buffer-dirs* :test #'equal))) + (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME? + (push target-dir target-suffix-dirs) + (let* ((target-suffix (concat-dirs target-suffix-dirs)) ; PUSH reversed for us! + (buffer-root (concat-dirs (reverse (nthcdr pos buffer-dirs*))))) + (return (concat (slime-filesystem-toplevel-directory) + buffer-root + target-suffix + (file-name-nondirectory target-filename)))))))))) + +(defun slime-highlight-differences-in-dirname (base-dirname contrast-dirname) + "Returns a copy of BASE-DIRNAME where all differences between +BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a +highlighting face." + (setq base-dirname (file-name-as-directory base-dirname)) + (setq contrast-dirname (file-name-as-directory contrast-dirname)) + (flet ((insert-dir (dirname) + (insert (file-name-as-directory dirname))) + (insert-dir/propzd (dirname) + (slime-insert-propertized '(face highlight) dirname) + (insert "/"))) ; Not exactly portable (to VMS...) + (let ((base-dirs (slime-split-string base-dirname "/" t)) + (contrast-dirs (slime-split-string contrast-dirname "/" t))) + (with-temp-buffer + (loop initially (insert (slime-filesystem-toplevel-directory)) + for base-dir in base-dirs do + (let ((pos (position base-dir contrast-dirs :test #'equal))) + (if (not pos) + (insert-dir/propzd base-dir) + (progn (insert-dir base-dir) + (setq contrast-dirs (nthcdr (1+ pos) contrast-dirs)))))) + (buffer-substring (point-min) (point-max)))))) + +(defvar slime-warn-when-possibly-tricked-by-M-. t + "When working on multiple source trees simultaneously, the way +`slime-edit-definition' (M-.) works can sometimes be confusing: + +`M-.' visits locations that are present in the current Lisp image, +which works perfectly well as long as the image reflects the source +tree that one is currently looking at. + +In the other case, however, one can easily end up visiting a file +in a different source root directory (the one corresponding to +the Lisp image), and is thus easily tricked to modify the wrong +source files---which can lead to quite some stressfull cursing. + +If this variable is T, a warning message is issued to raise the +user's attention whenever `M-.' is about opening a file in a +different source root that also exists in the source root +directory of the user's current buffer. + +There's no guarantee that all possible cases are covered, but +if you encounter such a warning, it's a strong indication that +you should check twice before modifying.") + +(defun slime-maybe-warn-for-different-source-root (target-filename buffer-filename) + (when slime-warn-when-possibly-tricked-by-M-. + (let ((guessed-target (slime-file-name-merge-source-root target-filename + buffer-filename))) + (when (and guessed-target + (not (equal guessed-target target-filename)) + (file-exists-p guessed-target)) + (slime-message "Attention: This is `%s'." + (concat (slime-highlight-differences-in-dirname + (file-name-directory target-filename) + (file-name-directory guessed-target)) + (file-name-nondirectory target-filename))))))) + + +(defun slime-goto-location-buffer (buffer) + (flet ((file-truename-safe (filename) (and filename (file-truename filename)))) + (destructure-case buffer + ((:file filename) + (let ((target-filename (file-truename-safe (slime-from-lisp-filename filename))) + (buffer-filename (file-truename-safe (buffer-file-name)))) + (when buffer-filename + (slime-maybe-warn-for-different-source-root target-filename buffer-filename)) + (unless (and buffer-filename (string= buffer-filename target-filename)) + (set-buffer (find-file-noselect target-filename t)))) + (goto-char (point-min))) + ((:buffer buffer-name) + (let ((old-buffer-filename (file-truename-safe (buffer-file-name))) + (target-buffer-filename (file-truename-safe + (buffer-file-name (get-buffer buffer-name))))) + (when (and target-buffer-filename old-buffer-filename) + (slime-maybe-warn-for-different-source-root target-buffer-filename + old-buffer-filename))) + (set-buffer buffer-name) + (goto-char (point-min))) + ((:source-form string) + (set-buffer (get-buffer-create "*SLIME Source Form*")) + (erase-buffer) + (lisp-mode) + (insert string) + (goto-char (point-min))) + ((:zip file entry) + (require 'arc-mode) + (set-buffer (find-file-noselect file t)) + (goto-char (point-min)) + (re-search-forward (concat " " entry "$")) + (let ((buffer (save-window-excursion + (archive-extract) + (current-buffer)))) + (set-buffer buffer) + (goto-char (point-min))))))) + +(defun slime-goto-location-position (position) + (save-restriction-if-possible ; try to keep restriction if possible. + (widen) + (destructure-case position + ((:position pos &optional align-p) + (goto-char pos) + (when align-p + (slime-forward-sexp) + (beginning-of-sexp))) + ((:line start &optional column) + (goto-line start) + (cond (column (move-to-column column)) + (t (skip-chars-forward " \t")))) + ((:function-name name) + (let ((case-fold-search t) + (name (regexp-quote name))) + (or + (re-search-forward + (format "\\s *(def\$\\s_\\|\\sw\$*\\s +%s\\S_" name) nil t) + (re-search-forward + (format "\\s *(def\$\\s_\\|\\sw\$*\\s +(*%s\\S_" name) nil t) + (re-search-forward + (format "[( \t]%s\\>\$\\s \\|$\$" name) nil t))) + (goto-char (match-beginning 0))) + ((:method name specializers &rest qualifiers) + (slime-search-method-location name specializers qualifiers)) + ((:source-path source-path start-position) + (cond (start-position + (goto-char start-position) + (slime-forward-positioned-source-path source-path)) + (t + (slime-forward-source-path source-path)))) + ;; Goes to "start" then looks for the anchor text, then moves + ;; delta from that position. + ((:text-anchored start text delta) + (goto-char start) + (slime-isearch text) + (forward-char delta))))) + +(defun slime-search-method-location (name specializers qualifiers) + ;; Look for a sequence of words (def<something> method name + ;; qualifers specializers don't look for "T" since it isn't requires + ;; (arg without t) as class is taken as such. + (let* ((case-fold-search t) + (name (regexp-quote name)) + (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>")) + qualifiers "")) + (specializers (mapconcat (lambda (el) + (if (eql (aref el 0) ?$) + (let ((spec (read el))) + (if (eq (car spec) 'EQL) + (concat ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" (format "%s" (second spec)) ")") + (error "don't understand specializer: %s,%s" el (car spec)))) + (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>"))) + (remove "T" specializers) "")) + (regexp (format "\\s *(def\\(\\s_\\|\\sw\$*\\s +%s\\s +%s%s" name + qualifiers specializers))) + (or (and (re-search-forward regexp nil t) + (goto-char (match-beginning 0))) + ;; (slime-goto-location-position `(:function-name ,name)) + ))) + +(defun slime-search-call-site (fname) + "Move to the place where FNAME called. +Don't move if there are multiple or no calls in the current defun." + (save-restriction + (narrow-to-defun) + (let ((start (point)) + (regexp (concat "(" fname "[\n \t]"))) + (cond ((and (re-search-forward regexp nil t) + (not (re-search-forward regexp nil t))) + (goto-char (match-beginning 0))) + (t (goto-char start)))))) + +(defun slime-goto-source-location (location &optional noerror) + "Move to the source location LOCATION. Several kinds of locations +are supported: + +<location> ::= (:location <buffer> <position> <hints>) + | (:error <message>) + +<buffer> ::= (:file <filename>) + | (:buffer <buffername>) + | (:source-form <string>) + | (:zip <file> <entry>) + +<position> ::= (:position <fixnum> [<align>]) ; 1 based + | (:line <line> [<column>]) + | (:function-name <string>) + | (:source-path <list> <start-position>) + | (:text-anchored <fixnum> <string> <fixnum>) + | (:method <name string> <specializer strings> . <qualifiers strings>)" + (destructure-case location + ((:location buffer position hints) + (slime-goto-location-buffer buffer) + (slime-goto-location-position position) + (when-let (snippet (getf hints :snippet)) + (slime-isearch snippet)) + (when-let (fname (getf hints :call-site)) + (slime-search-call-site fname))) + ((:error message) + (if noerror + (slime-message "%s" message) + (error "%s" message))))) + +(defmacro slime-point-moves-p (&rest body) + "Execute BODY and return true if the current buffer's point moved." + (let ((pointvar (gensym "point-"))) + `(let ((,pointvar (point))) + (save-current-buffer ,@body) + (/= ,pointvar (point))))) + +(put 'slime-point-moves-p 'lisp-indent-function 0) + +(defun slime-forward-sexp (&optional count) + "Like `forward-sexp', but understands reader-conditionals (#- and #+)." + (dotimes (i (or count 1)) + (while (slime-point-moves-p (slime-forward-blanks) + (slime-forward-reader-comment) + (slime-forward-reader-conditional))) + (forward-sexp))) + +(defun slime-forward-blanks () + "Move forward over all whitespace and newlines at point." + (ignore-errors + (while (slime-point-moves-p + (skip-syntax-forward " ") + ;; newlines aren't in lisp-mode's whitespace syntax class + (when (eolp) (forward-char)))))) + +;; Emacs 21's forward-sexp understands #| |# comments in lisp-mode +;; buffers, but (at least) Emacs 20's doesn't, so here it is. +(defun slime-forward-reader-comment () + "Move forward over #|...|# reader comments. The comments may be nested." + (when (looking-at "#|") + (goto-char (match-end 0)) + (while (not (looking-at "|#")) + (re-search-forward (regexp-opt '("|#" "#|"))) + (goto-char (match-beginning 0)) + (when (looking-at "#|") ; nested comment + (slime-forward-reader-comment))) + (goto-char (match-end 0)))) + +(defun slime-forward-reader-conditional () + "Move past any reader conditional (#+ or #-) at point." + (when (or (looking-at "#\\+") + (looking-at "#-")) + (goto-char (match-end 0)) + (let* ((plus-conditional-p (eq (char-before) ?+)) + (result (slime-eval-feature-conditional (read (current-buffer))))) + (unless (if plus-conditional-p result (not result)) + ;; skip this sexp + (slime-forward-sexp))))) + +(defun slime-keywordify (symbol) + "Make a keyword out of the symbol SYMBOL." + (let ((name (downcase (symbol-name symbol)))) + (intern (if (eq ?: (aref name 0)) + name + (concat ":" name))))) + +(defun slime-eval-feature-conditional (e) + "Interpret a reader conditional expression." + (if (symbolp e) + (memq (slime-keywordify e) (slime-lisp-features)) + (funcall (ecase (slime-keywordify (car e)) + (:and #'every) + (:or #'some) + (:not (lambda (f l) (not (apply f l))))) + #'slime-eval-feature-conditional + (cdr e)))) + + +;;;;; Incremental search +;; +;; Search for the longest match of a string in either direction. +;; +;; This is for locating text that is expected to be near the point and +;; may have been modified (but hopefully not near the beginning!) + +(defun slime-isearch (string) + "Find the longest occurence of STRING either backwards of forwards. +If multiple matches exist the choose the one nearest to point." + (goto-char + (let* ((start (point)) + (len1 (slime-isearch-with-function 'search-forward string)) + (pos1 (point))) + (goto-char start) + (let* ((len2 (slime-isearch-with-function 'search-backward string)) + (pos2 (point))) + (cond ((and len1 len2) + ;; Have a match in both directions + (cond ((= len1 len2) + ;; Both are full matches -- choose the nearest. + (if (< (abs (- start pos1)) + (abs (- start pos2))) + pos1 pos2)) + ((> len1 len2) pos1) + ((> len2 len1) pos2))) + (len1 pos1) + (len2 pos2) + (t start)))))) + +(defun slime-isearch-with-function (search-fn string) + "Search for the longest substring of STRING using SEARCH-FN. +SEARCH-FN is either the symbol `search-forward' or `search-backward'." + (unless (string= string "") + (loop for i from 1 to (length string) + while (funcall search-fn (substring string 0 i) nil t) + for match-data = (match-data) + do (case search-fn + (search-forward (goto-char (match-beginning 0))) + (search-backward (goto-char (1+ (match-end 0))))) + finally (return (if (null match-data) + nil + ;; Finish based on the last successful match + (store-match-data match-data) + (goto-char (match-beginning 0)) + (- (match-end 0) (match-beginning 0))))))) + + +;;;;; Visiting and navigating the overlays of compiler notes + +(defvar slime-compilation-just-finished nil + "A buffer local variable which is T when we've just compiled a +buffer and haven't yet started navigating its notes.") +(make-variable-buffer-local 'slime-compilation-just-finished) + +(defun slime-next-note () + "Go to and describe the next compiler note in the buffer." + (interactive) + (let ((here (point))) + (when (and slime-goto-first-note-after-compilation + slime-compilation-just-finished) + (goto-char (point-min)) + (setf slime-compilation-just-finished nil)) + (slime-find-next-note) + (if (slime-note-at-point) + (slime-show-note (slime-note-at-point)) + (progn + (goto-char here) + (message "No next note."))))) + +(defun slime-previous-note () + "Go to and describe the previous compiler note in the buffer." + (interactive) + (let ((here (point))) + (when (and slime-goto-first-note-after-compilation + slime-compilation-just-finished) + (goto-char (point-max)) + (setf slime-compilation-just-finished nil)) + (slime-find-previous-note) + (if (slime-note-at-point) + (slime-show-note (slime-note-at-point)) + (progn + (goto-char here) + (message "No previous note."))))) + +(defun slime-remove-notes () + "Remove compiler-note annotations from the current buffer." + (interactive) + (slime-remove-old-overlays)) + +(defun slime-show-note (overlay) + "Present the details of a compiler note to the user." + (slime-temporarily-highlight-note overlay) + (let ((message (get-char-property (point) 'help-echo))) + (slime-message "%s" (if (zerop (length message)) "\"\"" message)))) + +(defun slime-temporarily-highlight-note (overlay) + "Temporarily highlight a compiler note's overlay. +The highlighting is designed to both make the relevant source more +visible, and to highlight any further notes that are nested inside the +current one. + +The highlighting is automatically undone before the next Emacs command." + (lexical-let ((old-face (overlay-get overlay 'face)) + (overlay overlay)) + (push (lambda () (overlay-put overlay 'face old-face)) + slime-pre-command-actions) + (overlay-put overlay 'face 'slime-highlight-face))) + + +;;;;; Overlay lookup operations + +(defun slime-note-at-point () + "Return the overlay for a note starting at point, otherwise NIL." + (find (point) (slime-note-overlays-at-point) + :key 'overlay-start)) + +(defun slime-note-overlay-p (overlay) + "Return true if OVERLAY represents a compiler note." + (overlay-get overlay 'slime)) + +(defun slime-note-overlays-at-point () + "Return a list of all note overlays that are under the point." + (remove-if-not 'slime-note-overlay-p (overlays-at (point)))) + +(defun slime-find-next-note () + "Go to the next position with the `slime-note' text property. +Retuns true if such a position is found." + (slime-find-note 'next-single-char-property-change)) + +(defun slime-find-previous-note () + "Go to the next position with the `slime' text property. +Returns true if such a position is found." + (slime-find-note 'previous-single-char-property-change)) + +(defun slime-find-note (next-candidate-fn) + "Seek out the beginning of a note. +NEXT-CANDIDATE-FN is called to find each new position for consideration." + (let ((origin (point))) + (loop do (goto-char (funcall next-candidate-fn (point) 'slime)) + until (or (slime-note-at-point) + (eobp) + (bobp))) + (unless (slime-note-at-point) + (goto-char origin)))) + + +;;;; Arglist Display + +(defun slime-space (n) + "Insert a space and print some relevant information (function arglist). +Designed to be bound to the SPC key. Prefix argument can be used to insert +more than one space." + (interactive "p") + (self-insert-command n) + (when (and slime-space-information-p + (slime-background-activities-enabled-p)) + (slime-echo-arglist))) + +(defvar slime-echo-arglist-function 'slime-show-arglist) + +(defun slime-echo-arglist () + "Display the arglist of the current form in the echo area." + (funcall slime-echo-arglist-function)) + +(defun slime-show-arglist () + (let ((op (slime-operator-before-point))) + (when op + (slime-eval-async `(swank:operator-arglist ,op ,(slime-current-package)) + (lambda (arglist) + (when arglist + (slime-message "%s" arglist))))))) + +(defun slime-operator-before-point () + (ignore-errors + (save-excursion + (backward-up-list 1) + (down-list 1) + (slime-symbol-name-at-point)))) + + +;;;; Completion + +;; XXX those long names are ugly to read; long names an indicator for +;; bad factoring? + +(defvar slime-completions-buffer-name "*Completions*") + +(make-variable-buffer-local + (defvar slime-complete-saved-window-configuration nil + "Window configuration before we show the *Completions* buffer. +This is buffer local in the buffer where the completion is +performed.")) + +(make-variable-buffer-local + (defvar slime-completions-window nil + "The window displaying *Completions* after saving window configuration. +If this window is no longer active or displaying the completions +buffer then we can ignore `slime-complete-saved-window-configuration'.")) + +(defun slime-complete-maybe-save-window-configuration () + "Maybe save the current window configuration. +Return true if the configuration was saved." + (unless (or slime-complete-saved-window-configuration + (get-buffer-window slime-completions-buffer-name)) + (setq slime-complete-saved-window-configuration + (current-window-configuration)) + t)) + +(defun slime-complete-delay-restoration () + (make-local-hook 'pre-command-hook) + (add-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-configuration)) + +(defun slime-complete-forget-window-configuration () + (setq slime-complete-saved-window-configuration nil) + (setq slime-completions-window nil)) + +(defun slime-complete-restore-window-configuration () + "Restore the window config if available." + (remove-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-configuration) + (when (and slime-complete-saved-window-configuration + (slime-completion-window-active-p)) + ;; XEmacs does not allow us to restore a window configuration from + ;; pre-command-hook, so we do it asynchronously. + (slime-run-when-idle + (lambda () + (save-excursion + (set-window-configuration + slime-complete-saved-window-configuration)) + (setq slime-complete-saved-window-configuration nil) + (when (buffer-live-p slime-completions-buffer-name) + (kill-buffer slime-completions-buffer-name)))))) + +(defun slime-complete-maybe-restore-window-configuration () + "Restore the window configuration, if the following command +terminates a current completion." + (remove-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-configuration) + (condition-case err + (cond ((find last-command-char "()\"'`,# \r\n:") + (slime-complete-restore-window-configuration)) + ((not (slime-completion-window-active-p)) + (slime-complete-forget-window-configuration)) + (t + (slime-complete-delay-restoration))) + (error + ;; Because this is called on the pre-command-hook, we mustn't let + ;; errors propagate. + (message "Error in slime-complete-restore-window-configuration: %S" err)))) + +(defun slime-completion-window-active-p () + "Is the completion window currently active?" + (and (window-live-p slime-completions-window) + (equal (buffer-name (window-buffer slime-completions-window)) + slime-completions-buffer-name))) + +(defun slime-display-completion-list (completions base) + (let ((savedp (slime-complete-maybe-save-window-configuration))) + (with-output-to-temp-buffer slime-completions-buffer-name + (display-completion-list completions) + (let ((offset (- (point) 1 (length base)))) + (with-current-buffer standard-output + (setq completion-base-size offset) + (set-syntax-table lisp-mode-syntax-table)))) + (when savedp + (setq slime-completions-window + (get-buffer-window slime-completions-buffer-name))))) + +(defun slime-display-or-scroll-completions (completions base) + (cond ((and (eq last-command this-command) + (slime-completion-window-active-p)) + (slime-scroll-completions)) + (t + (slime-display-completion-list completions base))) + (slime-complete-delay-restoration)) + +(defun slime-scroll-completions () + (let ((window slime-completions-window)) + (with-current-buffer (window-buffer window) + (if (pos-visible-in-window-p (point-max) window) + (set-window-start window (point-min)) + (save-selected-window + (select-window window) + (scroll-up)))))) + +(defun slime-complete-symbol () + "Complete the symbol at point. + +Completion is performed by `slime-complete-symbol-function'." + (interactive) + (funcall slime-complete-symbol-function)) + +(defun slime-simple-complete-symbol () + "Complete the symbol at point. +Perform completion more similar to Emacs' complete-symbol." + (or (slime-maybe-complete-as-filename) + (let* ((end (point)) + (beg (slime-symbol-start-pos)) + (prefix (buffer-substring-no-properties beg end)) + (result (slime-simple-completions prefix))) + (destructuring-bind (completions partial) result + (if (null completions) + (progn (slime-minibuffer-respecting-message + "Can't find completion for \"%s\"" prefix) + (ding) + (slime-complete-restore-window-configuration)) + (insert-and-inherit (substring partial (length prefix))) + (cond ((slime-length= completions 1) + (slime-minibuffer-respecting-message "Sole completion") + (slime-complete-restore-window-configuration)) + ;; Incomplete + (t + (slime-minibuffer-respecting-message + "Complete but not unique") + (slime-display-or-scroll-completions completions + partial)))))))) + +(defun slime-maybe-complete-as-filename () + "If point is at a string starting with \", complete it as filename. +Return nil iff if point is not at filename." + (if (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) + (let ((comint-completion-addsuffix '("/" . "\""))) + (if slime-when-complete-filename-expand + (comint-replace-by-expanded-filename) + (comint-dynamic-complete-as-filename)) + t) + nil)) + +(defun slime-minibuffer-respecting-message (format &rest format-args) + "Display TEXT as a message, without hiding any minibuffer contents." + (let ((text (format " [%s]" (apply #'format format format-args)))) + (if (minibuffer-window-active-p (minibuffer-window)) + (if (fboundp 'temp-minibuffer-message) ;; XEmacs + (temp-minibuffer-message text) + (minibuffer-message text)) + (message "%s" text)))) + +(defvar slime-read-expression-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map "\t" 'slime-complete-symbol) + (define-key map "\M-\t" 'slime-complete-symbol) + map) + "Minibuffer keymap used for reading CL expressions.") + +(defvar slime-read-expression-history '() + "History list of expressions read from the minibuffer.") + +(defun slime-read-from-minibuffer (prompt &optional initial-value) + "Read a string from the minibuffer, prompting with PROMPT. +If INITIAL-VALUE is non-nil, it is inserted into the minibuffer before +reading input. The result is a string (\"\" if no input was given)." + (let ((minibuffer-setup-hook + (cons (lexical-let ((package (slime-current-package)) + (connection (slime-connection))) + (lambda () + (setq slime-buffer-package package) + (setq slime-buffer-connection connection) + (set-syntax-table lisp-mode-syntax-table))) + minibuffer-setup-hook))) + (read-from-minibuffer prompt initial-value slime-read-expression-map + nil 'slime-read-expression-history))) + +(defun slime-bogus-completion-alist (list) + "Make an alist out of list. +The same elements go in the CAR, and nil in the CDR. To support the +apparently very stupid `try-completions' interface, that wants an +alist but ignores CDRs." + (mapcar (lambda (x) (cons x nil)) list)) + +(defun slime-simple-completions (prefix) + (slime-eval `(swank:simple-completions ,prefix ',(slime-current-package)))) + + +;;;; Edit definition + +(defvar slime-find-definition-history-ring (make-ring 20) + "History ring recording the definition-finding \"stack\".") + +(defun slime-push-definition-stack (&optional marker narrowing-configuration) + "Add MARKER and NARROWING-CONFIGURATION to the edit-definition history stack. +If MARKER is nil, use the current point. If NARROWING-CONFIGURATION is nil, +look if the current buffer is narrowed, and if so use the relevant values." + (ring-insert-at-beginning slime-find-definition-history-ring + (list (or marker (point-marker)) + (or narrowing-configuration + (slime-current-narrowing-configuration))))) + +(defun slime-pop-find-definition-stack () + "Pop the edit-definition stack and goto the location." + (interactive) + (unless (ring-empty-p slime-find-definition-history-ring) + (destructuring-bind (marker narrowing-cfg) + (ring-remove slime-find-definition-history-ring) + (let ((buffer (marker-buffer marker)) + (narrowedp (slime-narrowing-configuration.narrowedp narrowing-cfg)) + (narrow-beg (slime-narrowing-configuration.beg narrowing-cfg)) + (narrow-end (slime-narrowing-configuration.end narrowing-cfg))) + (if (buffer-live-p buffer) + (progn (switch-to-buffer buffer) + (goto-char (marker-position marker)) + (when narrowedp + (narrow-to-region narrow-beg narrow-end))) + ;; If this buffer was deleted, recurse to try the next one + (slime-pop-find-definition-stack)))))) + +(defstruct (slime-definition (:conc-name slime-definition.) + (:type list)) + dspec location) + +(defun slime-edit-definition (name &optional where) + "Lookup the definition of the name at point. +If there's no name at point, or a prefix argument is given, then the +function name is prompted." + (interactive (list (slime-read-symbol-name "Name: "))) + (let ((definitions (slime-eval `(swank:find-definitions-for-emacs ,name)))) + (cond + ((null definitions) + (if slime-edit-definition-fallback-function + (funcall slime-edit-definition-fallback-function name) + (error "No known definition for: %s" name))) + ((and (slime-length= definitions 1) + (eql (car (slime-definition.location (car definitions))) :error)) + (if slime-edit-definition-fallback-function + (funcall slime-edit-definition-fallback-function name) + (error "%s" (cadr (slime-definition.location (car definitions)))))) + (t + (slime-goto-definition name definitions where))))) + +(defun slime-find-tag-if-tags-table-visited (name) + "Find tag (in current tags table) whose name contains NAME. +If no tags table is visited, don't offer to visit one; +just signal that no definition is known." + (if tags-table-list + (find-tag name) + (error "No known definition for: %s; use M-x visit-tags-table RET" name))) + +(defun slime-goto-definition (name definitions &optional where) + (slime-push-definition-stack) + (let ((all-locations-equal + (or (null definitions) + (let ((first-location (slime-definition.location (first definitions)))) + (every (lambda (definition) + (equal (slime-definition.location definition) + first-location)) + (rest definitions)))))) + (if (and (slime-length> definitions 1) + (not all-locations-equal)) + (slime-show-definitions name definitions) + (let ((def (car definitions))) + (destructure-case (slime-definition.location def) + ;; Take care of errors before switching any windows/buffers. + ((:error message) + (error "%s" message)) + (t + (cond ((equal where 'window) + (slime-goto-definition-other-window (car definitions))) + ((equal where 'frame) + (let ((pop-up-frames t)) + (slime-goto-definition-other-window (car definitions)))) + (t + (slime-goto-source-location (slime-definition.location + (car definitions))) + (switch-to-buffer (current-buffer)))))))))) + +(defun slime-goto-definition-other-window (definition) + (slime-pop-to-other-window) + (slime-goto-source-location (slime-definition.location definition)) + (switch-to-buffer (current-buffer))) + +(defun slime-pop-to-other-window () + "Pop to the other window, but not to any particular buffer." + (pop-to-buffer (current-buffer) t)) + +(defun slime-edit-definition-other-window (name) + "Like `slime-edit-definition' but switch to the other window." + (interactive (list (slime-read-symbol-name "Symbol: "))) + (slime-edit-definition name 'window)) + +(defun slime-edit-definition-other-frame (name) + "Like `slime-edit-definition' but switch to the other window." + (interactive (list (slime-read-symbol-name "Symbol: "))) + (slime-edit-definition name 'frame)) + +(defun slime-edit-definition-with-etags (name) + (interactive (list (slime-read-symbol-name "Symbol: "))) + (let ((tagdefs (slime-etags-definitions name))) + (cond (tagdefs + (message "Using tag file...") + (slime-goto-definition name tagdefs)) + (t + (error "No known definition for: %s" name))))) + +(defun slime-etags-definitions (name) + "Search definitions matching NAME in the tags file. +The result is a (possibly empty) list of definitions." + (require 'etags) + (let ((defs '())) + (save-excursion + (let ((first-time t)) + (while (visit-tags-table-buffer (not first-time)) + (setq first-time nil) + (goto-char (point-min)) + (while (search-forward name nil t) + (beginning-of-line) + (destructuring-bind (hint line &rest pos) (etags-snarf-tag) + (unless (eq hint t) ; hint==t if we are in a filename line + (let ((file (expand-file-name (file-of-tag)))) + (let ((loc `(:location (:file ,file) + (:line ,line) + (:snippet ,hint)))) + (push (list hint loc) defs)))))))) + (reverse defs)))) + +(defun slime-show-definitions (name definitions) + (slime-show-xrefs + `((,name . ,(loop for (dspec location) in definitions + collect (cons dspec location)))) + 'definition + name + (slime-current-package))) + +;;;;; first-change-hook + +(defun slime-first-change-hook () + "Notify Lisp that a source file's buffer has been modified." + ;; Be careful not to disturb anything! + ;; In particular if we muck up the match-data then query-replace + ;; breaks. -luke (26/Jul/2004) + (save-excursion + (save-match-data + (when (and (buffer-file-name) + (file-exists-p (buffer-file-name)) + (slime-background-activities-enabled-p)) + (let ((filename (slime-to-lisp-filename (buffer-file-name)))) + (slime-eval-async `(swank:buffer-first-change ,filename))))))) + +(defun slime-setup-first-change-hook () + (add-hook (make-local-variable 'first-change-hook) + 'slime-first-change-hook)) + +(add-hook 'slime-mode-hook 'slime-setup-first-change-hook) + + +;;;; Eval for Lisp + +(defun slime-eval-for-lisp (thread tag form-string) + (let ((ok nil) + (value nil) + (c (slime-connection))) + (unwind-protect (progn + (slime-check-eval-in-emacs-enabled) + (setq value (eval (read form-string))) + (setq ok t)) + (let ((result (if ok `(:ok ,value) `(:abort)))) + (slime-dispatch-event `(:emacs-return ,thread ,tag ,result) c))))) + +(defun slime-check-eval-in-emacs-enabled () + "Raise an error if `slime-enable-evaluate-in-emacs' isn't true." + (unless slime-enable-evaluate-in-emacs + (error "slime-eval-in-emacs disabled for security. Set slime-enable-evaluate-in-emacs true to enable it."))) + + +;;;; `ED' + +(defvar slime-ed-frame nil + "The frame used by `slime-ed'.") + +(defcustom slime-ed-use-dedicated-frame t + "*When non-nil, `slime-ed' will create and reuse a dedicated frame." + :type 'boolean + :group 'slime-mode) + +(defun slime-ed (what) + "Edit WHAT. + +WHAT can be: + A filename (string), + A list (FILENAME LINE [COLUMN]), + A list (FILENAME :charpos CHARPOS), + A function name (symbol or cons), + nil. + +This is for use in the implementation of COMMON-LISP:ED." + ;; Without `save-excursion' very strange things happen if you call + ;; (swank:ed-in-emacs X) from the REPL. -luke (18/Jan/2004) + (save-excursion + (when slime-ed-use-dedicated-frame + (unless (and slime-ed-frame (frame-live-p slime-ed-frame)) + (setq slime-ed-frame (make-frame))) + (select-frame slime-ed-frame)) + (cond ((stringp what) + (find-file (slime-from-lisp-filename what))) + ((and (consp what) (stringp (first what))) + (find-file (first (slime-from-lisp-filename what))) + (cond + ((eql (second what) :charpos) + (goto-char (third what))) + (t + (goto-line (second what)) + ;; Find the correct column, without going past the end of + ;; the line. + (let ((col (third what))) + (while (and col + (< (point) (point-at-eol)) + (/= (decf col) -1)) + (forward-char 1)))))) + ((and what (symbolp what)) + (slime-edit-definition (symbol-name what))) + ((consp what) + (slime-edit-definition (prin1-to-string what))) + (t nil)))) ; nothing in particular + + +;;;; Interactive evaluation. + +(defun slime-interactive-eval (string) + "Read and evaluate STRING and print value in minibuffer. + +Note: If a prefix argument is in effect then the result will be +inserted in the current buffer." + (interactive (list (slime-read-from-minibuffer "Slime Eval: "))) + (slime-insert-transcript-delimiter string) + (cond ((not current-prefix-arg) + (slime-eval-with-transcript `(swank:interactive-eval ,string) + 'slime-display-eval-result)) + (t + (slime-eval-print string)))) + +(defun slime-display-eval-result (value) + (slime-message "%s" value)) + +(defun slime-eval-print (string) + "Eval STRING in Lisp; insert any output and the result at point." + (slime-eval-async `(swank:eval-and-grab-output ,string) + (lexical-let ((buffer (current-buffer))) + (lambda (result) + (with-current-buffer buffer + (destructuring-bind (output value) result + (insert output value))))))) + +(defun slime-eval-with-transcript (form &optional fn) + "Send FROM and PACKAGE to Lisp and pass the result to FN. +Display the result in the message area, if FN is nil. +Show the output buffer if the evaluation causes any output." + (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (slime-mark-output-start))) + (with-lexical-bindings (fn) + (slime-eval-async form + (lambda (value) + (with-current-buffer (slime-output-buffer) + (slime-show-last-output) + (cond (fn (funcall fn value)) + (t (message "%s" value)))))))) + +(defun slime-eval-describe (form) + "Evaluate FORM in Lisp and display the result in a new buffer." + (lexical-let ((package (slime-current-package))) + (slime-eval-with-transcript + form (lambda (string) (slime-show-description string package))))) + +(defun slime-insert-transcript-delimiter (string) + (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (unless (bolp) (insert-before-markers "\n")) + (slime-propertize-region '(slime-transcript-delimiter t) + (insert-before-markers + ";;;; " (subst-char-in-string ?\n ?\ + (substring string 0 + (min 60 (length string)))) + " ...\n"))))) + +(defun slime-display-buffer-region (buffer start end &optional other-window) + "Like `display-buffer', but only display the specified region." + (let ((window-min-height 1)) + (with-current-buffer buffer + (save-excursion + (save-restriction + (goto-char start) + (beginning-of-line) + (narrow-to-region (point) end) + (let ((window (display-buffer buffer other-window t))) + (set-window-start window (point)) + (unless (or (one-window-p t) + (/= (frame-width) (window-width))) + (set-window-text-height window (/ (1- (frame-height)) 2))) + (shrink-window-if-larger-than-buffer window) + window)))))) + +(defun slime-last-expression () + (buffer-substring-no-properties + (save-excursion (backward-sexp) (point)) + (point))) + +(defun slime-eval-last-expression () + "Evaluate the expression preceding point." + (interactive) + (slime-interactive-eval (slime-last-expression))) + +(defun slime-eval-last-expression-display-output () + "Display output buffer and evaluate the expression preceding point." + (interactive) + (slime-display-output-buffer) + (slime-interactive-eval (slime-last-expression))) + +(defun slime-eval-defun () + "Evaluate the current toplevel form. +Use `slime-re-evaluate-defvar' if the from starts with '(defvar'" + (interactive) + (let ((form (slime-defun-at-point))) + (cond ((string-match "^(defvar " form) + (slime-re-evaluate-defvar form)) + (t + (slime-interactive-eval form))))) + +(defun slime-eval-region (start end) + "Evaluate region." + (interactive "r") + (slime-eval-with-transcript + `(swank:interactive-eval-region + ,(buffer-substring-no-properties start end)))) + +(defun slime-eval-buffer () + "Evaluate the current buffer. +The value is printed in the echo area." + (interactive) + (slime-eval-region (point-min) (point-max))) + +(defun slime-re-evaluate-defvar (form) + "Force the re-evaluaton of the defvar form before point. + +First make the variable unbound, then evaluate the entire form." + (interactive (list (slime-last-expression))) + (slime-eval-with-transcript `(swank:re-evaluate-defvar ,form))) + +(defun slime-pprint-eval-last-expression () + "Evaluate the form before point; pprint the value in a buffer." + (interactive) + (slime-eval-describe `(swank:pprint-eval ,(slime-last-expression)))) + +(defun slime-eval-print-last-expression (string) + "Evaluate sexp before point; print value into the current buffer" + (interactive (list (slime-last-expression))) + (insert "\n") + (slime-eval-print string)) + +(defun slime-call-defun () + "Insert a call to the function defined around point into the REPL." + (interactive) + (let ((toplevel (slime-parse-toplevel-form))) + (unless (and (consp toplevel) + (member (car toplevel) '(:defun :defmethod :defgeneric)) + (symbolp (cadr toplevel))) + (error "Not in a function definition")) + (let* ((symbol (cadr toplevel)) + (function-call + (format "(%s " (slime-qualify-cl-symbol-name symbol)))) + (slime-switch-to-output-buffer) + (goto-char slime-repl-input-start-mark) + (insert function-call) + (save-excursion (insert ")"))))) + +;;;; Edit Lisp value +;;; +(defun slime-edit-value (form-string) + "\\<slime-edit-value-mode-map>\ +Edit the value of a setf'able form in a new buffer. +The value is inserted into a temporary buffer for editing and then set +in Lisp when committed with \\[slime-edit-value-commit]." + (interactive + (list (slime-read-from-minibuffer "Edit value (evaluated): " + (slime-sexp-at-point)))) + (slime-eval-async `(swank:value-for-editing ,form-string) + (lexical-let ((form-string form-string) + (package (slime-current-package))) + (lambda (result) + (slime-edit-value-callback form-string result + package))))) + +(make-variable-buffer-local + (defvar slime-edit-form-string nil + "The form being edited by `slime-edit-value'.")) + +(define-minor-mode slime-edit-value-mode + "Mode for editing a Lisp value." + nil + " edit" + '(("\C-c\C-c" . slime-edit-value-commit))) + +(defun slime-edit-value-callback (form-string current-value package) + (let ((name (generate-new-buffer-name (format "*Edit %s*" form-string)))) + (with-current-buffer (slime-get-temp-buffer-create name :mode 'lisp-mode) + (slime-mode 1) + (slime-temp-buffer-mode -1) ; don't want binding of 'q' + (slime-edit-value-mode 1) + (setq slime-edit-form-string form-string) + (setq slime-buffer-connection (slime-connection)) + (setq slime-buffer-package package) + (insert current-value)))) + +(defun slime-edit-value-commit () + "Commit the edited value to the Lisp image. +\\(See `slime-edit-value'.)" + (interactive) + (if (null slime-edit-form-string) + (error "Not editing a value.") + (let ((value (buffer-substring-no-properties (point-min) (point-max)))) + (lexical-let ((buffer (current-buffer))) + (slime-eval-async `(swank:commit-edited-value ,slime-edit-form-string + ,value) + (lambda (_) + (with-current-buffer buffer + (slime-temp-buffer-quit t)))))))) + +;;;; Tracing + +(defun slime-redirect-trace-output () + "Redirect the trace output to a separate Emacs buffer." + (interactive) + (let ((buffer (get-buffer-create "*SLIME Trace Output*"))) + (with-current-buffer buffer + (let ((marker (copy-marker (buffer-size))) + (target (incf slime-last-output-target-id))) + (puthash target marker slime-output-target-to-marker) + (slime-eval `(swank:redirect-trace-output ,target)))) + ;; Note: We would like the entries in + ;; slime-output-target-to-marker to disappear when the buffers are + ;; killed. We cannot just make the hash-table ":weakness 'value" + ;; -- there is no reference from the buffers to the markers in the + ;; buffer, so entries would disappear even though the buffers are + ;; alive. Best solution might be to make buffer-local variables + ;; that keep the markers. --mkoeppe + (pop-to-buffer buffer))) + +(defun slime-untrace-all () + "Untrace all functions." + (interactive) + (slime-eval `(swank:untrace-all))) + +(defun slime-toggle-trace-fdefinition (&optional using-context-p) + "Toggle trace." + (interactive "P") + (let* ((spec (if using-context-p + (slime-extract-context) + (slime-symbol-name-at-point))) + (spec (slime-trace-query spec))) + (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec))))) + +(defun slime-trace-query (spec) + "Ask the user which function to trace; SPEC is the default. +The result is a string." + (cond ((null spec) + (slime-read-from-minibuffer "(Un)trace: ")) + ((stringp spec) + (slime-read-from-minibuffer "(Un)trace: " spec)) + (t + (destructure-case spec + ((setf n) + (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) + (((:defun :defmacro) n) + (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string n))) + ((:defgeneric n) + (let* ((name (prin1-to-string n)) + (answer (slime-read-from-minibuffer "(Un)trace: " name))) + (cond ((and (string= name answer) + (y-or-n-p (concat "(Un)trace also all " + "methods implementing " + name "? "))) + (prin1-to-string `(:defgeneric ,n))) + (t + answer)))) + ((:defmethod &rest _) + (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) + ((:call caller callee) + (let* ((callerstr (prin1-to-string caller)) + (calleestr (prin1-to-string callee)) + (answer (slime-read-from-minibuffer "(Un)trace: " + calleestr))) + (cond ((and (string= calleestr answer) + (y-or-n-p (concat "(Un)trace only when " calleestr + " is called by " callerstr "? "))) + (prin1-to-string `(:call ,caller ,callee))) + (t + answer)))) + (((:labels :flet) &rest _) + (slime-read-from-minibuffer "(Un)trace local function: " + (prin1-to-string spec))))))) + +(defun slime-extract-context () + "Parse the context for the symbol at point. +Nil is returned if there's no symbol at point. Otherwise we detect +the following cases (the . shows the point position): + + (defun n.ame (...) ...) -> (:defun name) + (defun (setf n.ame) (...) ...) -> (:defun (setf name)) + (defmethod n.ame (...) ...) -> (:defmethod name (...)) + (defun ... (...) (labels ((n.ame (...) -> (:labels (:defun ...) name) + (defun ... (...) (flet ((n.ame (...) -> (:flet (:defun ...) name) + (defun ... (...) ... (n.ame ...) ...) -> (:call (:defun ...) name) + (defun ... (...) ... (setf (n.ame ...) -> (:call (:defun ...) (setf name)) + +For other contexts we return the symbol at point." + (let ((name (slime-symbol-name-at-point))) + (if name + (let ((symbol (read name))) + (or (progn ;;ignore-errors + (slime-parse-context symbol)) + symbol))))) + +(defun slime-parse-context (name) + (save-excursion + (cond ((slime-in-expression-p '(defun *)) `(:defun ,name)) + ((slime-in-expression-p '(defmacro *)) `(:defmacro ,name)) + ((slime-in-expression-p '(defgeneric *)) `(:defgeneric ,name)) + ((slime-in-expression-p '(setf *)) + ;;a setf-definition, but which? + (backward-up-list 1) + (slime-parse-context `(setf ,name))) + ((slime-in-expression-p '(defmethod *)) + (unless (looking-at "\\s ") + (forward-sexp 1)) ; skip over the methodname + (let (qualifiers arglist) + (loop for e = (read (current-buffer)) + until (listp e) do (push e qualifiers) + finally (setq arglist e)) + `(:defmethod ,name ,@qualifiers + ,(slime-arglist-specializers arglist)))) + ((and (symbolp name) + (slime-in-expression-p `(,name))) + ;; looks like a regular call + (let ((toplevel (ignore-errors (slime-parse-toplevel-form)))) + (cond ((slime-in-expression-p `(setf (*))) ;a setf-call + (if toplevel + `(:call ,toplevel (setf ,name)) + `(setf ,name))) + ((not toplevel) + name) + ((slime-in-expression-p `(labels ((*)))) + `(:labels ,toplevel ,name)) + ((slime-in-expression-p `(flet ((*)))) + `(:flet ,toplevel ,name)) + (t + `(:call ,toplevel ,name))))) + (t + name)))) + +(defun slime-in-expression-p (pattern) + "A helper function to determine the current context. +The pattern can have the form: + pattern ::= () ;matches always + | (*) ;matches inside a list + | (<symbol> <pattern>) ;matches if the first element in + ; the current list is <symbol> and + ; if <pattern> matches. + | ((<pattern>)) ;matches if we are in a nested list." + (save-excursion + (let ((path (reverse (slime-pattern-path pattern)))) + (loop for p in path + always (ignore-errors + (etypecase p + (symbol (slime-beginning-of-list) + (eq (read (current-buffer)) p)) + (number (backward-up-list p) + t))))))) + +(defun slime-pattern-path (pattern) + ;; Compute the path to the * in the pattern to make matching + ;; easier. The path is a list of symbols and numbers. A number + ;; means "(down-list <n>)" and a symbol "(look-at <sym>)") + (if (null pattern) + '() + (etypecase (car pattern) + ((member *) '()) + (symbol (cons (car pattern) (slime-pattern-path (cdr pattern)))) + (cons (cons 1 (slime-pattern-path (car pattern))))))) + +(defun slime-beginning-of-list (&optional up) + "Move backward the the beginning of the current expression. +Point is placed before the first expression in the list." + (backward-up-list (or up 1)) + (down-list 1) + (skip-syntax-forward " ")) + +(defun slime-parse-toplevel-form () + (save-excursion + (beginning-of-defun) + (down-list 1) + (forward-sexp 1) + (slime-parse-context (read (current-buffer))))) + +(defun slime-arglist-specializers (arglist) + (cond ((or (null arglist) + (member (first arglist) '(&optional &key &rest &aux))) + (list)) + ((consp (first arglist)) + (cons (second (first arglist)) + (slime-arglist-specializers (rest arglist)))) + (t + (cons 't + (slime-arglist-specializers (rest arglist)))))) + +(defun slime-disassemble-symbol (symbol-name) + "Display the disassembly for SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "Disassemble: "))) + (slime-eval-describe `(swank:disassemble-symbol ,symbol-name))) + +(defun slime-undefine-function (symbol-name) + "Unbind the function slot of SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "fmakunbound: " t))) + (slime-eval-async `(swank:undefine-function ,symbol-name) + (lambda (result) (message "%s" result)))) + +(defun slime-load-file (filename) + "Load the Lisp file FILENAME." + (interactive (list + (read-file-name "Load file: " nil nil + nil (if (buffer-file-name) + (file-name-nondirectory + (buffer-file-name)))))) + (let ((lisp-filename (slime-to-lisp-filename (expand-file-name filename)))) + (slime-eval-with-transcript `(swank:load-file ,lisp-filename)))) + + + + +;;;; Profiling + +(defun slime-toggle-profile-fdefinition (fname-string) + "Toggle profiling for FNAME-STRING." + (interactive (list (slime-read-from-minibuffer + "(Un)Profile: " + (slime-symbol-name-at-point)))) + (slime-eval-async `(swank:toggle-profile-fdefinition ,fname-string) + (lambda (r) (message "%s" r)))) + +(defun slime-unprofile-all () + "Unprofile all functions." + (interactive) + (slime-eval-async '(swank:unprofile-all) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-report () + "Print profile report." + (interactive) + (slime-eval-with-transcript '(swank:profile-report))) + +(defun slime-profile-reset () + "Reset profile counters." + (interactive) + (slime-eval-async (slime-eval `(swank:profile-reset)) + (lambda (r) (message "%s" r)))) + +(defun slime-profiled-functions () + "Return list of names of currently profiled functions." + (interactive) + (slime-eval-async `(swank:profiled-functions) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-package (package callers methods) + "Profile all functions in PACKAGE. +If CALLER is non-nil names have counts of the most common calling +functions recorded. +If METHODS is non-nil, profile all methods of all generic function +having names in the given package." + (interactive (list (slime-read-package-name "Package: ") + (y-or-n-p "Record the most common callers? ") + (y-or-n-p "Profile methods? "))) + (slime-eval-async `(swank:profile-package ,package ,callers ,methods) + (lambda (r) (message "%s" r)))) + + + +;;;; Documentation + +(defun slime-hyperspec-lookup (symbol-name) + "A wrapper for `hyperspec-lookup'" + (interactive (list (let* ((symbol-at-point (slime-symbol-name-at-point)) + (stripped-symbol + (and symbol-at-point + (downcase + (common-lisp-hyperspec-strip-cl-package + symbol-at-point))))) + (if (and stripped-symbol + (intern-soft stripped-symbol + common-lisp-hyperspec-symbols)) + stripped-symbol + (completing-read + "Look up symbol in Common Lisp HyperSpec: " + common-lisp-hyperspec-symbols #'boundp + t stripped-symbol + 'common-lisp-hyperspec-history))))) + (hyperspec-lookup symbol-name)) + +(defun slime-show-description (string package) + (slime-with-output-to-temp-buffer ("*SLIME Description*") + package (princ string))) + +(defun slime-describe-symbol (symbol-name) + "Describe the symbol at point." + (interactive (list (slime-read-symbol-name "Describe symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe `(swank:describe-symbol ,symbol-name))) + +(defun slime-documentation (symbol-name) + "Display function- or symbol-documentation for SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "Documentation for symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe + `(swank:documentation-symbol ,symbol-name "(not documented)"))) + +(defun slime-describe-function (symbol-name) + (interactive (list (slime-read-symbol-name "Describe symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe `(swank:describe-function ,symbol-name))) + +(defun slime-apropos-summary (string case-sensitive-p package only-external-p) + "Return a short description for the performed apropos search." + (concat (if case-sensitive-p "Case-sensitive " "") + "Apropos for " + (format "%S" string) + (if package (format " in package %S" package) "") + (if only-external-p " (external symbols only)" ""))) + +(defun slime-apropos (string &optional only-external-p package + case-sensitive-p) + "Show all bound symbols whose names match STRING, a regular expression." + (interactive + (if current-prefix-arg + (list (read-string "SLIME Apropos: ") + (y-or-n-p "External symbols only? ") + (let ((pkg (slime-read-package-name "Package: "))) + (if (string= pkg "") nil pkg)) + (y-or-n-p "Case-sensitive? ")) + (list (read-string "SLIME Apropos: ") t nil nil))) + (let ((buffer-package (or package (slime-current-package)))) + (slime-eval-async + `(swank:apropos-list-for-emacs ,string ,only-external-p + ,case-sensitive-p ',package) + (lexical-let ((string string) + (package buffer-package) + (summary (slime-apropos-summary string case-sensitive-p + package only-external-p))) + (lambda (r) (slime-show-apropos r string package summary)))))) + +(defun slime-apropos-all () + "Shortcut for (slime-apropos <pattern> nil nil)" + (interactive) + (slime-apropos (read-string "SLIME Apropos: ") nil nil)) + +(defun slime-apropos-package (package &optional internal) + "Show apropos listing for symbols in PACKAGE. +With prefix argument include internal symbols." + (interactive (list (let ((pkg (slime-read-package-name "Package: "))) + (if (string= pkg "") (slime-current-package) pkg)) + current-prefix-arg)) + (slime-apropos "" (not internal) package)) + +(defun slime-show-apropos (plists string package summary) + (if (null plists) + (message "No apropos matches for %S" string) + (slime-with-output-to-temp-buffer ("*SLIME Apropos*" :mode apropos-mode) + package + (set-syntax-table lisp-mode-syntax-table) + (slime-mode t) + (if (boundp 'header-line-format) + (setq header-line-format summary) + (insert summary "\n\n")) + (slime-set-truncate-lines) + (slime-print-apropos plists)))) + +(defvar slime-apropos-label-properties + (progn + (require 'apropos) + (cond ((and (boundp 'apropos-label-properties) + (symbol-value 'apropos-label-properties))) + ((boundp 'apropos-label-face) + (etypecase (symbol-value 'apropos-label-face) + (symbol `(face ,(or (symbol-value 'apropos-label-face) + 'italic) + mouse-face highlight)) + (list (symbol-value 'apropos-label-face))))))) + +(eval-when-compile (require 'apropos)) + +(defun slime-print-apropos (plists) + (dolist (plist plists) + (let ((designator (plist-get plist :designator))) + (assert designator) + (slime-insert-propertized (list 'face apropos-symbol-face + 'item designator + 'action 'slime-describe-symbol) + designator)) + (terpri) + (let ((apropos-label-properties slime-apropos-label-properties)) + (loop for (prop namespace) + in '((:variable "Variable") + (:function "Function") + (:generic-function "Generic Function") + (:macro "Macro") + (:special-operator "Special Operator") + (:setf "Setf") + (:type "Type") + (:class "Class") + (:alien-type "Alien type") + (:alien-struct "Alien struct") + (:alien-union "Alien type") + (:alien-enum "Alien enum")) + ;; Properties not listed here will not show up in the buffer + do + (let ((value (plist-get plist prop)) + (start (point))) + (when value + (princ " ") + (slime-insert-propertized apropos-label-properties namespace) + (princ ": ") + (princ (etypecase value + (string value) + ((member :not-documented) "(not documented)"))) + (add-text-properties + start (point) + (list 'type prop 'action 'slime-call-describer + 'button t 'apropos-label namespace + 'item (plist-get plist :designator))) + (terpri))))))) + +(defun slime-call-describer (arg) + (let* ((pos (if (markerp arg) arg (point))) + (type (get-text-property pos 'type)) + (item (get-text-property pos 'item))) + (slime-eval-describe `(swank:describe-definition-for-emacs ,item ,type)))) + + +;;;; XREF: cross-referencing + +(defvar slime-xref-mode-map) +(defvar slime-xref-saved-emacs-snapshot nil + "Buffer local variable in xref windows.") + +(define-derived-mode slime-xref-mode lisp-mode "xref" + "slime-xref-mode: Major mode for cross-referencing. +\\<slime-xref-mode-map>\ +The most important commands: +\\[slime-xref-quit] - Dismiss buffer. +\\[slime-show-xref] - Display referenced source and keep xref window. +\\[slime-goto-xref] - Jump to referenced source and dismiss xref window. + +\\{slime-xref-mode-map}" + (setq font-lock-defaults nil) + (setq delayed-mode-hooks nil) + (slime-mode -1)) + +(slime-define-keys slime-xref-mode-map + ((kbd "RET") 'slime-show-xref) + ("\C-m" 'slime-show-xref) + (" " 'slime-goto-xref) + ("q" 'slime-xref-quit) + ("n" 'slime-next-line/not-add-newlines) + ("p" 'previous-line)) + +(defun slime-next-line/not-add-newlines () + (interactive) + (let ((next-line-add-newlines nil)) + (next-line 1))) + +;; FIXME: binding SLDB keys in xref buffer? -luke +(dolist (spec slime-keys) + (destructuring-bind (key command &key sldb prefixed &allow-other-keys) spec + (when sldb + (let ((key (if prefixed (concat slime-prefix-key key) key))) + (define-key slime-xref-mode-map key command))))) + + +;;;;; XREF results buffer and window management + +(defun slime-xref-buffer () + "Return the XREF results buffer. +If CREATE is non-nil, create it if necessary." + (or (find-if (lambda (b) (string-match "*XREF\\[" (buffer-name b))) + (buffer-list)) + (error "No XREF buffer"))) + +(defun slime-init-xref-buffer (package ref-type symbol) + "Initialize the current buffer for displaying XREF information." + (slime-xref-mode) + (setq buffer-read-only nil) + (erase-buffer) + (setq slime-buffer-package package) + (slime-set-truncate-lines)) + +;; XXX: unused function +(defun slime-display-xref-buffer () + "Display the XREF results buffer in a window and select it." + (let* ((buffer (slime-xref-buffer)) + (window (get-buffer-window buffer))) + (if (and window (window-live-p window)) + (select-window window) + (select-window (display-buffer buffer t)) + (shrink-window-if-larger-than-buffer)))) + +(defmacro* slime-with-xref-buffer ((package ref-type symbol &key emacs-snapshot) + &body body) + "Execute BODY in a xref buffer, then show that buffer." + (let ((type (gensym "TYPE+")) (sym (gensym "SYM+")) + (pkg (gensym "PKG+")) (snapshot (gensym "SNAPSHOT+"))) + `(let ((,type ,ref-type) (,sym ,symbol) (,pkg ,package)) + ;; We don't want the the xref buffer to be the current buffer + ;; in the snapshot, so we gotta take the snapshot here. + (let ((,snapshot (or ,emacs-snapshot (slime-current-emacs-snapshot)))) + (with-current-buffer (get-buffer-create + (format "*XREF[%s: %s]*" ,type ,sym)) + (prog2 (progn + (slime-init-xref-buffer ,pkg ,type ,sym) + (make-local-variable 'slime-xref-saved-emacs-snapshot) + (setq slime-xref-saved-emacs-snapshot ,snapshot)) + (progn ,@body) + (setq buffer-read-only t) + (select-window (or (get-buffer-window (current-buffer) t) + (display-buffer (current-buffer) t))) + (shrink-window-if-larger-than-buffer))))))) + +(put 'slime-with-xref-buffer 'lisp-indent-function 1) + +(defun slime-insert-xrefs (xrefs) + "Insert XREFS in the current-buffer. +XREFS is a list of the form ((GROUP . ((LABEL . LOCATION) ...)) ...) +GROUP and LABEL are for decoration purposes. LOCATION is a source-location." + (unless (bobp) (insert "\n")) + (loop for (group . refs) in xrefs do + (progn + (slime-insert-propertized '(face bold) group "\n") + (loop + for (label . location) in refs + do (slime-insert-propertized + (list 'slime-location location + 'face 'font-lock-keyword-face) + " " (slime-one-line-ify label)) + do (insert " - " (if (and (eql :location (car location)) + (assoc :file (cdr location))) + (second (assoc :file (cdr location))) + "file unknown") + "\n")))) + ;; Remove the final newline to prevent accidental window-scrolling + (backward-char 1) + (delete-char 1)) + +(defvar slime-next-location-function nil + "Function to call for going to the next location.") + +(defun slime-show-xrefs (xrefs type symbol package &optional emacs-snapshot) + "Show the results of an XREF query." + (if (null xrefs) + (message "No references found for %s." symbol) + (setq slime-next-location-function 'slime-goto-next-xref) + (slime-with-xref-buffer (package type symbol :emacs-snapshot emacs-snapshot) + (slime-insert-xrefs xrefs) + (goto-char (point-min)) + (forward-line) + (skip-chars-forward " \t")))) + + +;;;;; XREF commands + +(defun slime-who-calls (symbol) + "Show all known callers of the function SYMBOL." + (interactive (list (slime-read-symbol-name "Who calls: " t))) + (slime-xref :calls symbol)) + +(defun slime-calls-who (symbol) + "Show all known functions called by the function SYMBOL." + (interactive (list (slime-read-symbol-name "Who calls: " t))) + (slime-xref :calls-who symbol)) + +(defun slime-who-references (symbol) + "Show all known referrers of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who references: " t))) + (slime-xref :references symbol)) + +(defun slime-who-binds (symbol) + "Show all known binders of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who binds: " t))) + (slime-xref :binds symbol)) + +(defun slime-who-sets (symbol) + "Show all known setters of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who sets: " t))) + (slime-xref :sets symbol)) + +(defun slime-who-macroexpands (symbol) + "Show all known expanders of the macro SYMBOL." + (interactive (list (slime-read-symbol-name "Who macroexpands: " t))) + (slime-xref :macroexpands symbol)) + +(defun slime-who-specializes (symbol) + "Show all known methods specialized on class SYMBOL." + (interactive (list (slime-read-symbol-name "Who specializes: " t))) + (slime-xref :specializes symbol)) + +(defun slime-list-callers (symbol-name) + "List the callers of SYMBOL-NAME in a xref window." + (interactive (list (slime-read-symbol-name "List callers: "))) + (slime-xref :callers symbol-name)) + +(defun slime-list-callees (symbol-name) + "List the callees of SYMBOL-NAME in a xref window." + (interactive (list (slime-read-symbol-name "List callees: "))) + (slime-xref :callees symbol-name)) + +(defun slime-xref (type symbol) + "Make an XREF request to Lisp." + (slime-eval-async + `(swank:xref ',type ',symbol) + (lexical-let ((type type) + (symbol symbol) + (package (slime-current-package)) + ;; We have to take the snapshot here, because SLIME-EVAL-ASYNC + ;; is invoking its continuation within the extent of a different + ;; buffer. (2007-08-14) + (snapshot (slime-current-emacs-snapshot))) + (lambda (result) + (slime-show-xrefs result type symbol package snapshot))))) + + +;;;;; XREF navigation + +(defun slime-xref-location-at-point () + (save-excursion + ;; When the end of the last line is at (point-max) we can't find + ;; the text property there. Going to bol avoids this problem. + (beginning-of-line 1) + (or (get-text-property (point) 'slime-location) + (error "No reference at point.")))) + +(defun slime-goto-xref () + "Goto the cross-referenced location at point." + (interactive) + (let ((location (slime-xref-location-at-point))) + (slime-xref-cleanup) + (slime-goto-source-location location) + (switch-to-buffer (current-buffer)))) + +(defun slime-show-xref () + "Display the xref at point in the other window." + (interactive) + (let ((location (slime-xref-location-at-point))) + (slime-show-source-location location))) + +(defun slime-goto-next-xref () + "Goto the next cross-reference location." + (let ((location (with-current-buffer (slime-xref-buffer) + (let ((w (display-buffer (current-buffer) t))) + (goto-char (1+ (next-single-char-property-change + (point) 'slime-location))) + (set-window-point w (point))) + (cond ((eobp) + (message "No more xrefs.") + nil) + (t + (slime-xref-location-at-point)))))) + (when location + (slime-goto-source-location location) + (switch-to-buffer (current-buffer))))) + +(defun slime-next-location () + "Go to the next location, depending on context. +When displaying XREF information, this goes to the next reference." + (interactive) + (when (null slime-next-location-function) + (error "No context for finding locations.")) + (funcall slime-next-location-function)) + +(defun slime-xref-quit () + "Kill the current xref buffer and restore the window configuration." + (interactive) + (let ((snapshot slime-xref-saved-emacs-snapshot)) + (slime-xref-cleanup) + (slime-set-emacs-snapshot snapshot))) + +(defun slime-xref-cleanup () + "Delete overlays created by xref mode and kill the xref buffer." + (sldb-delete-overlays) + (let ((buffer (current-buffer))) + (delete-windows-on buffer) + (kill-buffer buffer))) + + +;;;; Macroexpansion + +(define-minor-mode slime-macroexpansion-minor-mode + "SLIME mode for macroexpansion" + nil + " temp" + '(("q" . slime-temp-buffer-quit) + ("g" . slime-macroexpand-again))) + +(flet ((remap (from to) + (dolist (mapping (where-is-internal from slime-mode-map)) + (define-key slime-macroexpansion-minor-mode-map mapping to)))) + (remap 'slime-macroexpand-1 'slime-macroexpand-1-inplace) + (remap 'slime-macroexpand-all 'slime-macroexpand-all-inplace) + (remap 'undo '(lambda (&optional arg) + (interactive) + (let ((buffer-read-only nil)) + (when (fboundp 'slime-remove-edits) + (slime-remove-edits (point-min) (point-max))) + (undo arg))))) + +(defun slime-sexp-at-point-for-macroexpansion () + "Essentially like SLIME-SEXP-AT-POINT-OR-ERROR, but behaves a +bit more sanely in situations like ,(loop ...) where you want to +expand the LOOP form. See comment in the source of this function." + (let ((string (slime-sexp-at-point-or-error)) + (bounds (bounds-of-thing-at-point 'sexp)) + (char-at-point (substring-no-properties (thing-at-point 'char)))) + ;; SLIME-SEXP-AT-POINT(-OR-ERROR) uses (THING-AT-POINT 'SEXP) + ;; which is quite a bit botched: it returns "'(FOO BAR BAZ)" even + ;; when point is placed _at the opening parenthesis_, and hence + ;; "(FOO BAR BAZ)" wouldn't get expanded. Likewise for ",(...)", + ;; ",@(...)" (would return "@(...)"!!), and "\"(...)". + ;; So we better fix this up here: + (when (string= char-at-point "(") + (let ((char0 (elt string 0))) + (when (member char0 '(?\' ?\, ?\" ?\@)) + (setf string (substring string 1)) + (incf (car bounds))))) + (list string bounds))) + +(defvar slime-eval-macroexpand-expression nil + "Specifies the last macroexpansion preformed. This variable + specifies both what was expanded and how.") + +(defun slime-eval-macroexpand (expander &optional string) + (unless string + (setf string (first (slime-sexp-at-point-for-macroexpansion)))) + (setf slime-eval-macroexpand-expression `(,expander ,string)) + (lexical-let ((package (slime-current-package))) + (slime-eval-async + slime-eval-macroexpand-expression + (lambda (expansion) + (slime-with-output-to-temp-buffer + ;; reusep for preserving `undo' functionality. + ("*SLIME macroexpansion*" :mode lisp-mode :reusep t) package + (slime-macroexpansion-minor-mode) + (erase-buffer) + (insert expansion) + (font-lock-fontify-buffer)))))) + +(defun slime-eval-macroexpand-inplace (expander) + "Substitutes the current sexp at place with its macroexpansion. + +NB: Does not affect *slime-eval-macroexpand-expression*" + (interactive) + (destructuring-bind (string bounds) + (slime-sexp-at-point-for-macroexpansion) + (lexical-let* ((start (car bounds)) + (end (cdr bounds)) + (point (point)) + (package (slime-current-package)) + (buffer (current-buffer))) + (slime-eval-async + `(,expander ,string) + (lambda (expansion) + (with-current-buffer buffer + (let ((buffer-read-only nil)) + (when (fboundp 'slime-remove-edits) + (slime-remove-edits (point-min) (point-max))) + (goto-char start) + (delete-region start end) + (insert expansion) + (goto-char start) + (indent-sexp) + (goto-char point)))))))) + +(defun slime-macroexpand-1 (&optional repeatedly) + "Display the macro expansion of the form at point. The form is +expanded with CL:MACROEXPAND-1 or, if a prefix argument is given, with +CL:MACROEXPAND." + (interactive "P") + (slime-eval-macroexpand + (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1))) + +(defun slime-macroexpand-1-inplace (&optional repeatedly) + (interactive "P") + (slime-eval-macroexpand-inplace + (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1))) + +(defun slime-macroexpand-all () + "Display the recursively macro expanded sexp at point." + (interactive) + (slime-eval-macroexpand 'swank:swank-macroexpand-all)) + +(defun slime-macroexpand-all-inplace () + "Display the recursively macro expanded sexp at point." + (interactive) + (slime-eval-macroexpand-inplace 'swank:swank-macroexpand-all)) + +(defun slime-compiler-macroexpand () + "Display the compiler-macro expansion of sexp at point." + (interactive) + (slime-eval-macroexpand 'swank:swank-compiler-macroexpand)) + +(defun slime-compiler-macroexpand-1 () + "Display the compiler-macro expansion of sexp at point." + (interactive) + (slime-eval-macroexpand 'swank:swank-compiler-macroexpand-1)) + +(defun slime-macroexpand-again () + "Reperform the last macroexpansion." + (interactive) + (slime-eval-macroexpand (first slime-eval-macroexpand-expression) + (second slime-eval-macroexpand-expression))) + + +;;;; Subprocess control + +(defun slime-interrupt () + "Interrupt Lisp." + (interactive) + (cond ((slime-use-sigint-for-interrupt) (slime-send-sigint)) + (t (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread))))) + +(defun slime-quit () + (error "Not implemented properly. Use `slime-interrupt' instead.")) + +(defun slime-quit-lisp (&optional keep-buffers) + "Quit lisp, kill the inferior process and associated buffers." + (interactive) + (slime-eval-async '(swank:quit-lisp)) + (kill-buffer (slime-output-buffer)) + (set-process-filter (slime-connection) nil) + (set-process-sentinel (slime-connection) 'slime-quit-sentinel)) + +(defun slime-quit-sentinel (process message) + (assert (process-status process) 'closed) + (let* ((inferior (slime-inferior-process process)) + (inferior-buffer (if inferior (process-buffer inferior)))) + (when inferior (delete-process inferior)) + (when inferior-buffer (kill-buffer inferior-buffer)) + (slime-net-close process) + (message "Connection closed."))) + +(defun slime-set-package (package) + (interactive (list (slime-read-package-name "Package: " + (slime-find-buffer-package)))) + (message "*package*: %s" (slime-eval `(swank:set-package ,package)))) + +(defun slime-set-default-directory (directory) + "Make DIRECTORY become Lisp's current directory." + (interactive (list (read-directory-name "Directory: " nil nil t))) + (message "default-directory: %s" + (slime-from-lisp-filename + (slime-eval `(swank:set-default-directory + ,(slime-to-lisp-filename directory))))) + (with-current-buffer (slime-output-buffer) + (setq default-directory (expand-file-name directory)))) + +(defun slime-sync-package-and-default-directory () + "Set Lisp's package and directory to the values in current buffer." + (interactive) + (let ((package (slime-eval `(swank:set-package + ,(slime-find-buffer-package)))) + (directory (slime-from-lisp-filename + (slime-eval `(swank:set-default-directory + ,(slime-to-lisp-filename + default-directory)))))) + (let ((dir default-directory)) + ;; Sync REPL dir + (with-current-buffer (slime-output-buffer) + (setq default-directory dir)) + ;; Sync *inferior-lisp* dir + (let* ((proc (slime-process)) + (buffer (and proc (process-buffer proc)))) + (when buffer + (with-current-buffer buffer + (setq default-directory dir))))) + (message "package: %s default-directory: %s" (car package) directory))) + + +;;;; Debugger (SLDB) + +(defvar sldb-hook nil + "Hook run on entry to the debugger.") + + +;;;;; Local variables in the debugger buffer + +(slime-make-variables-buffer-local + (defvar sldb-condition nil + "A list (DESCRIPTION TYPE) describing the condition being debugged.") + + (defvar sldb-saved-window-configuration nil + "Window configuration before the debugger was initially entered.") + + (defvar sldb-restarts nil + "List of (NAME DESCRIPTION) for each available restart.") + + (defvar sldb-level nil + "Current debug level (recursion depth) displayed in buffer.") + + (defvar sldb-backtrace-start-marker nil + "Marker placed at the beginning of the backtrace text.") + + (defvar sldb-continuations nil + "List of ids for pending continuation.")) + +;;;;; SLDB macros + +;; some macros that we need to define before the first use + +(defmacro in-sldb-face (name string) + "Return STRING propertised with face sldb-NAME-face." + (let ((facename (intern (format "sldb-%s-face" (symbol-name name)))) + (var (gensym "string"))) + `(let ((,var ,string)) + (slime-add-face ',facename ,var) + ,var))) + +(put 'in-sldb-face 'lisp-indent-function 1) + +(defun slime-add-face (face string) + (add-text-properties 0 (length string) (list 'face face) string) + string) + + +;;;;; sldb-mode + +(defvar sldb-mode-syntax-table + (let ((table (copy-syntax-table lisp-mode-syntax-table))) + ;; We give < and > parenthesis syntax, so that #< ... > is treated + ;; as a balanced expression. This enables autodoc-mode to match + ;; #<unreadable> actual arguments in the backtraces with formal + ;; arguments of the function. (For Lisp mode, this is not + ;; desirable, since we do not wish to get a mismatched paren + ;; highlighted everytime we type < or >.) + (modify-syntax-entry ?< "(" table) + (modify-syntax-entry ?> ")" table) + table) + "Syntax table for SLDB mode.") + +(define-derived-mode sldb-mode fundamental-mode "sldb" + "Superior lisp debugger mode. In addition to ordinary SLIME commands, +the following are available:\\<sldb-mode-map> + +Commands to examine the selected frame: + \\[sldb-toggle-details] - toggle details (local bindings, CATCH tags) + \\[sldb-show-source] - view source for the frame + \\[sldb-eval-in-frame] - eval in frame + \\[sldb-pprint-eval-in-frame] - eval in frame, pretty-print result + \\[sldb-disassemble] - disassemble + \\[sldb-inspect-in-frame] - inspect + +Commands to invoke restarts: + \\[sldb-quit] - quit + \\[sldb-abort] - abort + \\[sldb-continue] - continue + \\[sldb-invoke-restart-0]-\\[sldb-invoke-restart-9] - restart shortcuts + +Commands to navigate frames: + \\[sldb-down] - down + \\[sldb-up] - up + \\[sldb-details-down] - down, with details + \\[sldb-details-up] - up, with details + +Miscellaneous commands: + \\[sldb-restart-frame] - restart frame + \\[sldb-return-from-frame] - return from frame + \\[sldb-step] - step + \\[sldb-break-with-default-debugger] - switch to default debugger + \\[slime-interactive-eval] - eval + +Full list of commands: + +\\{sldb-mode-map}" + (erase-buffer) + (set-syntax-table sldb-mode-syntax-table) + (slime-set-truncate-lines) + ;; Make original slime-connection "sticky" for SLDB commands in this buffer + (setq slime-buffer-connection (slime-connection)) + (add-local-hook 'kill-buffer-hook 'sldb-delete-overlays)) + +(slime-define-keys sldb-mode-map + ("h" 'describe-mode) + ("v" 'sldb-show-source) + ((kbd "RET") 'sldb-default-action) + ("\C-m" 'sldb-default-action) + ([mouse-2] 'sldb-default-action/mouse) + ([follow-link] 'mouse-face) + ("e" 'sldb-eval-in-frame) + ("d" 'sldb-pprint-eval-in-frame) + ("D" 'sldb-disassemble) + ("i" 'sldb-inspect-in-frame) + ("n" 'sldb-down) + ("p" 'sldb-up) + ("\M-n" 'sldb-details-down) + ("\M-p" 'sldb-details-up) + ("<" 'sldb-beginning-of-backtrace) + (">" 'sldb-end-of-backtrace) + ("t" 'sldb-toggle-details) + ("r" 'sldb-restart-frame) + ("R" 'sldb-return-from-frame) + ("c" 'sldb-continue) + ("s" 'sldb-step) + ("x" 'sldb-next) + ("o" 'sldb-out) + ("b" 'sldb-break-on-return) + ("a" 'sldb-abort) + ("q" 'sldb-quit) + ("B" 'sldb-break-with-default-debugger) + ("P" 'sldb-print-condition) + ("C" 'sldb-inspect-condition) + (":" 'slime-interactive-eval) + ("\C-c\C-d" slime-doc-map)) + +;; Inherit bindings from slime-mode +(dolist (spec slime-keys) + (destructuring-bind (key command &key sldb prefixed &allow-other-keys) spec + (when sldb + (let ((key (if prefixed (concat slime-prefix-key key) key))) + (define-key sldb-mode-map key command))))) + +;; Keys 0-9 are shortcuts to invoke particular restarts. +(defmacro define-sldb-invoke-restart-key (number key) + (let ((fname (intern (format "sldb-invoke-restart-%S" number))) + (docstring (format "Invoke restart numbered %S." number))) + `(progn + (defun ,fname () + ,docstring + (interactive) + (sldb-invoke-restart ,number)) + (define-key sldb-mode-map ,key ',fname)))) + +(defmacro define-sldb-invoke-restart-keys (from to) + `(progn + ,@(loop for n from from to to + collect `(define-sldb-invoke-restart-key ,n + ,(number-to-string n))))) + +(define-sldb-invoke-restart-keys 0 9) + + +;;;;; SLDB buffer creation & update + +(defun sldb-buffers () + "Return a list of all sldb buffers." + (slime-filter-buffers (lambda () (eq major-mode 'sldb-mode)))) + +(defun sldb-find-buffer (thread &optional connection) + (let ((connection (or connection (slime-connection)))) + (find-if (lambda (buffer) + (with-current-buffer buffer + (and (eq slime-buffer-connection connection) + (eq slime-current-thread thread)))) + (sldb-buffers)))) + +(defun sldb-get-default-buffer () + "Get a sldb buffer. +The buffer is chosen more or less randomly." + (car (sldb-buffers))) + +(defun sldb-get-buffer (thread &optional connection) + "Find or create a sldb-buffer for THREAD." + (let ((connection (or connection (slime-connection)))) + (or (sldb-find-buffer thread connection) + (let ((name (format "*sldb %s/%s*" (slime-connection-name) thread))) + (with-current-buffer (generate-new-buffer name) + (setq slime-buffer-connection connection + slime-current-thread thread) + (current-buffer)))))) + +(defun sldb-debugged-continuations (connection) + "Return the debugged continuations for CONNECTION." + (lexical-let ((accu '())) + (dolist (b (sldb-buffers)) + (with-current-buffer b + (when (eq slime-buffer-connection connection) + (setq accu (append sldb-continuations accu))))) + accu)) + +(defun sldb-setup (thread level condition restarts frames conts) + "Setup a new SLDB buffer. +CONDITION is a string describing the condition to debug. +RESTARTS is a list of strings (NAME DESCRIPTION) for each available restart. +FRAMES is a list (NUMBER DESCRIPTION) describing the initial +portion of the backtrace. Frames are numbered from 0. +CONTS is a list of pending Emacs continuations." + (with-current-buffer (sldb-get-buffer thread) + (unless (equal sldb-level level) + (setq buffer-read-only nil) + (sldb-mode) + (unless sldb-saved-window-configuration + (setq sldb-saved-window-configuration (current-window-configuration))) + (setq slime-current-thread thread) + (setq sldb-level level) + (setq mode-name (format "sldb[%d]" sldb-level)) + (setq sldb-condition condition) + (setq sldb-restarts restarts) + (setq sldb-continuations conts) + (sldb-insert-condition condition) + (insert "\n\n" (in-sldb-face section "Restarts:") "\n") + (sldb-insert-restarts restarts) + (insert "\n" (in-sldb-face section "Backtrace:") "\n") + (setq sldb-backtrace-start-marker (point-marker)) + (save-excursion + (sldb-insert-frames (sldb-prune-initial-frames frames) t)) + (run-hooks 'sldb-hook) + (pop-to-buffer (current-buffer)) + (sldb-recenter-region (point-min) (point)) + (setq buffer-read-only t) + (when (and slime-stack-eval-tags + ;; (y-or-n-p "Enter recursive edit? ") + ) + (message "Entering recursive edit..") + (recursive-edit))))) + +(defun sldb-activate (thread level) + "Display the debugger buffer for THREAD. +If LEVEL isn't the same as in the buffer, reinitialize the buffer." + (unless (let ((b (sldb-find-buffer thread))) + (and b (with-current-buffer b (equal sldb-level level)))) + (slime-rex (thread level) + ('(swank:debugger-info-for-emacs 0 10) + nil thread) + ((:ok result) + (apply #'sldb-setup thread level result))))) + +(defun sldb-exit (thread level &optional stepping) + "Exit from the debug level LEVEL." + (when-let (sldb (sldb-find-buffer thread)) + (with-current-buffer sldb + (unless stepping + (set-window-configuration sldb-saved-window-configuration)) + (let ((inhibit-read-only t)) + (erase-buffer)) + (setq sldb-level nil)) + (when (and (= level 1) (not stepping)) + (kill-buffer sldb)))) + +(defun sldb-insert-condition (condition) + "Insert the text for CONDITION. +CONDITION should be a list (MESSAGE TYPE EXTRAS). +EXTRAS is currently used for the stepper." + (destructuring-bind (message type extras) condition + (when (> (length message) 70) + (add-text-properties 0 (length message) (list 'help-echo message) + message)) + (slime-insert-propertized '(sldb-default-action sldb-inspect-condition) + (in-sldb-face topline message) + "\n" + (in-sldb-face condition type)) + (sldb-dispatch-extras extras))) + +(defvar sldb-extras-hooks) + +(defun sldb-dispatch-extras (extras) + ;; this is (mis-)used for the stepper + (dolist (extra extras) + (destructure-case extra + ((:show-frame-source n) + (sldb-show-frame-source n)) + (t + (or (run-hook-with-args-until-success 'sldb-extras-hooks extra) + ;;(error "Unhandled extra element:" extra) + ))))) + +(defun sldb-insert-restarts (restarts) + "Insert RESTARTS and add the needed text props +RESTARTS should be alist ((NAME DESCRIPTION) ...)." + (loop for (name string) in restarts + for number from 0 do + (insert " ") + (slime-insert-propertized + `(,@nil restart-number ,number + sldb-default-action sldb-invoke-restart + mouse-face highlight) + (in-sldb-face restart-number (number-to-string number)) + ": [" (in-sldb-face restart-type name) "] " + (in-sldb-face restart string)) + (insert "\n"))) + +(defun sldb-prune-initial-frames (frames) + "Return the prefix of FRAMES to initially present to the user. +Regexp heuristics are used to avoid showing SWANK-internal frames." + (let* ((case-fold-search t) + (rx "^\$[() ]\\|lambda\$*swank\\>")) + (or (loop for frame in frames + for (_ string) = frame + until (string-match rx string) + collect frame) + frames))) + +(defun sldb-insert-frames (frames more) + "Insert FRAMES into buffer. +If MORE is non-nil, more frames are on the Lisp stack." + (mapc #'sldb-insert-frame frames) + (when more + (destructuring-bind ((num _)) (last frames) + (slime-insert-propertized + `(,@nil sldb-default-action sldb-fetch-more-frames + sldb-previous-frame-number ,num + point-entered sldb-fetch-more-frames + start-open t + face sldb-section-face + mouse-face highlight) + " --more--") + (insert "\n")))) + +(defun sldb-insert-frame (frame &optional face) + "Insert FRAME with FACE at point. +If FACE is nil use `sldb-frame-line-face'." + (destructuring-bind (number string) frame + (let ((props `(frame ,frame sldb-default-action sldb-toggle-details))) + (slime-propertize-region props + (slime-propertize-region '(mouse-face highlight) + (insert " " (in-sldb-face frame-label (format "%2d:" number)) " ") + (slime-insert-indented + (slime-add-face (or face 'sldb-frame-line-face) + string))) + (insert "\n"))))) + +(defun sldb-fetch-more-frames (&rest ignore) + "Fetch more backtrace frames. +Called on the `point-entered' text-property hook." + (let ((inhibit-point-motion-hooks t) + (inhibit-read-only t) + (prev (get-text-property (point) 'sldb-previous-frame-number))) + ;; for unkown reasons, PREV is sometimes nil + (when prev + (let* ((count 40) + (from (1+ prev)) + (to (+ from count)) + (frames (slime-eval `(swank:backtrace ,from ,to))) + (more (slime-length= frames count)) + (pos (point))) + (delete-region (line-beginning-position) (point-max)) + (sldb-insert-frames frames more) + (goto-char pos))))) + + +;;;;;; SLDB examining text props + +(defun sldb-restart-at-point () + (or (get-text-property (point) 'restart-number) + (error "No restart at point"))) + +(defun sldb-frame-number-at-point () + (let ((frame (get-text-property (point) 'frame))) + (cond (frame (car frame)) + (t (error "No frame at point"))))) + +(defun sldb-var-number-at-point () + (let ((var (get-text-property (point) 'var))) + (cond (var var) + (t (error "No variable at point"))))) + +(defun sldb-previous-frame-number () + (save-excursion + (sldb-backward-frame) + (sldb-frame-number-at-point))) + +(defun sldb-frame-details-visible-p () + (and (get-text-property (point) 'frame) + (get-text-property (point) 'details-visible-p))) + +(defun sldb-frame-region () + (save-excursion + (goto-char (next-single-property-change (point) 'frame nil (point-max))) + (backward-char) + (values (previous-single-property-change (point) 'frame) + (next-single-property-change (point) 'frame nil (point-max))))) + +(defun sldb-forward-frame () + (goto-char (next-single-char-property-change (point) 'frame))) + +(defun sldb-backward-frame () + (goto-char (previous-single-char-property-change + (car (sldb-frame-region)) + 'frame + nil sldb-backtrace-start-marker))) + +(defun sldb-goto-last-frame () + (goto-char (point-max)) + (while (not (get-text-property (point) 'frame)) + (goto-char (previous-single-property-change (point) 'frame)))) + +(defun sldb-beginning-of-backtrace () + "Goto the first frame." + (interactive) + (goto-char sldb-backtrace-start-marker)) + + +;;;;;; SLDB recenter & redisplay + +;; FIXME: these functions need factorization + +(defvar sldb-show-location-recenter-arg nil + "Argument to pass to `recenter' when displaying a source location.") + +(defun slime-show-buffer-position (position) + "Ensure sure that the POSITION in the current buffer is visible." + (save-selected-window + (let ((w (select-window (or (get-buffer-window (current-buffer) t) + (display-buffer (current-buffer) t))))) + (goto-char position) + (push-mark) + (unless (pos-visible-in-window-p) + (slime-recenter-window w sldb-show-location-recenter-arg))))) + +(defun slime-recenter-window (window line) + "Set window-start in WINDOW LINE lines before point." + (let* ((line (if (not line) + (/ (window-height window) 2) + line)) + (start (save-excursion + (loop repeat line do (forward-line -1)) + (point)))) + (set-window-start window start))) + +(defun sldb-recenter-region (start end &optional center) + "Make the region from START to END visible. +Avoid point motions, if possible. +Minimize scrolling, if CENTER is nil. +If CENTER is true, scroll enough to center the region in the window." + (let ((pos (point)) (lines (count-screen-lines start end t))) + (assert (and (<= start pos) (<= pos end))) + ;;(sit-for 0) + (cond ((and (pos-visible-in-window-p start) + (pos-visible-in-window-p end))) + ((< lines (window-height)) + (cond (center (recenter (+ (/ (- (window-height) 1 lines) + 2) + (slime-count-lines start pos)))) + (t (recenter (+ (- (window-height) 1 lines) + (slime-count-lines start pos)))))) + (t + (goto-char start) + (recenter 0) + (cond ((pos-visible-in-window-p pos) + (goto-char pos)) + (t + (goto-char start) + (next-line (- (window-height) 2)))))))) + +;; not sure yet, whether this is a good idea. +(defmacro slime-save-coordinates (origin &rest body) + "Restore line and column relative to ORIGIN, after executing BODY. + +This is useful if BODY deletes and inserts some text but we want to +preserve the current row and column as closely as possible." + (let ((base (make-symbol "base")) + (goal (make-symbol "goal")) + (mark (make-symbol "mark"))) + `(let* ((,base ,origin) + (,goal (slime-coordinates ,base)) + (,mark (point-marker))) + (set-marker-insertion-type ,mark t) + (prog1 (save-excursion ,@body) + (slime-restore-coordinate ,base ,goal ,mark))))) + +(put 'slime-save-coordinates 'lisp-indent-function 1) + +(defun slime-coordinates (origin) + ;; Return a pair (X . Y) for the column and line distance to ORIGIN. + (let ((y (slime-count-lines origin (point))) + (x (save-excursion + (- (current-column) + (progn (goto-char origin) (current-column)))))) + (cons x y))) + +(defun slime-restore-coordinate (base goal limit) + ;; Move point to GOAL. Coordinates are relative to BASE. + ;; Don't move beyond LIMIT. + (save-restriction + (narrow-to-region base limit) + (goto-char (point-min)) + (let ((col (current-column))) + (forward-line (cdr goal)) + (when (and (eobp) (bolp) (not (bobp))) + (backward-char)) + (move-to-column (+ col (car goal)))))) + +(defun slime-count-lines (start end) + "Return the number of lines between START and END. +This is 0 if START and END at the same line." + (- (count-lines start end) + (if (save-excursion (goto-char end) (bolp)) 0 1))) + + +;;;;; SLDB commands + +(defun sldb-default-action () + "Invoke the action at point." + (interactive) + (let ((fn (get-text-property (point) 'sldb-default-action))) + (if fn (funcall fn)))) + +(defun sldb-default-action/mouse (event) + "Invoke the action pointed at by the mouse." + (interactive "e") + (destructuring-bind (mouse-1 (w pos &rest _)) event + (save-excursion + (goto-char pos) + (let ((fn (get-text-property (point) 'sldb-default-action))) + (if fn (funcall fn)))))) + +(defun sldb-end-of-backtrace () + "Fetch the entire backtrace and go to the last frame." + (interactive) + (sldb-fetch-all-frames) + (sldb-goto-last-frame)) + +(defun sldb-fetch-all-frames () + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (sldb-goto-last-frame) + (let ((last (sldb-frame-number-at-point))) + (goto-char (next-single-char-property-change (point) 'frame)) + (delete-region (point) (point-max)) + (save-excursion + (sldb-insert-frames (slime-eval `(swank:backtrace ,(1+ last) nil)) + nil))))) + + +;;;;;; SLDB show source + +(defvar sldb-overlays '() + "List of overlays created in source code buffers to highlight expressions.") + +(defun sldb-show-source () + "Highlight the frame at point's expression in a source code buffer." + (interactive) + (sldb-show-frame-source (sldb-frame-number-at-point))) + +(defun sldb-show-frame-source (frame-number) + (sldb-delete-overlays) + (slime-eval-async + `(swank:frame-source-location-for-emacs ,frame-number) + (lambda (source-location) + (destructure-case source-location + ((:error message) + (message "%s" message) + (ding)) + (t + (slime-show-source-location source-location)))))) + +(defun slime-show-source-location (source-location &optional no-highlight-p) + (slime-goto-source-location source-location) + (unless no-highlight-p (sldb-highlight-sexp)) + (slime-show-buffer-position (point))) + +(defun sldb-highlight-sexp (&optional start end) + "Highlight the first sexp after point." + (sldb-delete-overlays) + (let ((start (or start (point))) + (end (or end (save-excursion (ignore-errors (forward-sexp)) (point))))) + (push (make-overlay start (1+ start)) sldb-overlays) + (push (make-overlay (1- end) end) sldb-overlays)) + (dolist (overlay sldb-overlays) + (overlay-put overlay 'face 'secondary-selection))) + +(defun sldb-delete-overlays () + (mapc #'delete-overlay sldb-overlays) + (setq sldb-overlays '())) + + +;;;;;; SLDB toggle details + +(defun sldb-toggle-details (&optional on) + "Toggle display of details for the current frame. +The details include local variable bindings and CATCH-tags." + (interactive) + (assert (sldb-frame-number-at-point)) + (let ((inhibit-read-only t)) + (if (or on (not (sldb-frame-details-visible-p))) + (sldb-show-frame-details) + (sldb-hide-frame-details)))) + +(defun sldb-show-frame-details () + ;; fetch and display info about local variables and catch tags + (destructuring-bind (start end frame locals catches) (sldb-frame-details) + (slime-save-coordinates start + (delete-region start end) + (slime-propertize-region `(frame ,frame details-visible-p t) + (sldb-insert-frame frame 'sldb-detailed-frame-line-face) + (let ((indent1 " ") + (indent2 " ")) + (insert indent1 (in-sldb-face section + (if locals "Locals:" "[No Locals]")) "\n") + (sldb-insert-locals locals indent2 frame) + (when catches + (insert indent1 (in-sldb-face section "Catch-tags:") "\n") + (dolist (tag catches) + (slime-propertize-region `(catch-tag ,tag) + (insert indent2 (in-sldb-face catch-tag (format "%s" tag)) + "\n")))) + (setq end (point))))) + (sldb-recenter-region start end))) + +(defun sldb-frame-details () + ;; Return a list (START END FRAME LOCALS CATCHES) for frame at point. + (let* ((frame (get-text-property (point) 'frame)) + (num (car frame)) + (catches (sldb-catch-tags num)) + (locals (sldb-frame-locals num))) + (destructuring-bind (start end) (sldb-frame-region) + (list start end frame locals catches)))) + +(defun sldb-insert-locals (vars prefix frame) + "Insert VARS and add PREFIX at the beginning of each inserted line. +VAR should be a plist with the keys :name, :id, and :value." + (loop for i from 0 + for var in vars do + (destructuring-bind (&key name id value) var + (slime-propertize-region (list 'sldb-default-action 'sldb-inspect-var + 'var i) + (insert prefix + (in-sldb-face local-name + (concat name (if (zerop id) "" (format "#%d" id)))) + " = ") + (insert (in-sldb-face local-value value) "\n"))))) + +(defun sldb-hide-frame-details () + ;; delete locals and catch tags, but keep the function name and args. + (destructuring-bind (start end) (sldb-frame-region) + (let ((frame (get-text-property (point) 'frame))) + (slime-save-coordinates start + (delete-region start end) + (slime-propertize-region '(details-visible-p nil) + (sldb-insert-frame frame)))))) + +(defun sldb-disassemble () + "Disassemble the code for the current frame." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-disassemble ,frame) + (lambda (result) + (slime-show-description result nil))))) + +(defun sldb-print-condition () + "Print the condition SLDB is handling in the REPL. +This way you can still see what the error was after exiting SLDB." + (interactive) + (unless sldb-condition + (error "No condition known (wrong buffer?)")) + (slime-write-string (format "%s\n%s\n" + (first sldb-condition) + (second sldb-condition)))) + +(defun sldb-frame-locals (frame) + (slime-eval `(swank:frame-locals-for-emacs ,frame))) + +(defun sldb-catch-tags (frame) + (slime-eval `(swank:frame-catch-tags-for-emacs ,frame))) + + +;;;;;; SLDB eval and inspect + +(defun sldb-eval-in-frame (string) + "Prompt for an expression and evaluate it in the selected frame." + (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) + (let* ((number (sldb-frame-number-at-point))) + (slime-eval-async `(swank:eval-string-in-frame ,string ,number) + (if current-prefix-arg + 'slime-write-string + 'slime-display-eval-result)))) + +(defun sldb-pprint-eval-in-frame (string) + "Prompt for an expression, evaluate in selected frame, pretty-print result." + (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) + (let* ((number (sldb-frame-number-at-point))) + (slime-eval-async `(swank:pprint-eval-string-in-frame ,string ,number) + (lambda (result) + (slime-show-description result nil))))) + + + +(defun sldb-inspect-in-frame (string) + "Prompt for an expression and inspect it in the selected frame." + (interactive (list (slime-read-from-minibuffer + "Inspect in frame (evaluated): " + (slime-sexp-at-point)))) + (let ((number (sldb-frame-number-at-point))) + (slime-eval-async `(swank:inspect-in-frame ,string ,number) + 'slime-open-inspector))) + +(defun sldb-inspect-var () + (let ((frame (sldb-frame-number-at-point)) + (var (sldb-var-number-at-point))) + (slime-eval-async `(swank:inspect-frame-var ,frame ,var) + 'slime-open-inspector))) + +(defun sldb-inspect-condition () + "Inspect the current debugger condition." + (interactive) + (slime-eval-async '(swank:inspect-current-condition) + 'slime-open-inspector)) + + +;;;;;; SLDB movement + +(defun sldb-down () + "Select next frame." + (interactive) + (sldb-forward-frame)) + +(defun sldb-up () + "Select previous frame." + (interactive) + (sldb-backward-frame) + (when (= (point) sldb-backtrace-start-marker) + (recenter (1+ (count-lines (point-min) (point)))))) + +(defun sldb-sugar-move (move-fn) + (let ((inhibit-read-only t)) + (when (sldb-frame-details-visible-p) (sldb-hide-frame-details)) + (funcall move-fn) + (sldb-show-source) + (sldb-toggle-details t))) + +(defun sldb-details-up () + "Select previous frame and show details." + (interactive) + (sldb-sugar-move 'sldb-up)) + +(defun sldb-details-down () + "Select next frame and show details." + (interactive) + (sldb-sugar-move 'sldb-down)) + + +;;;;;; SLDB restarts + +(defun sldb-quit () + "Quit to toplevel." + (interactive) + (slime-rex () ('(swank:throw-to-toplevel)) + ((:ok _) (error "sldb-quit returned")) + ((:abort)))) + +(defun sldb-continue () + "Invoke the \"continue\" restart." + (interactive) + (slime-rex () + ('(swank:sldb-continue)) + ((:ok _) + (message "No restart named continue") + (ding)) + ((:abort)))) + +(defun sldb-abort () + "Invoke the \"abort\" restart." + (interactive) + (slime-eval-async '(swank:sldb-abort) + (lambda (v) (message "Restart returned: %S" v)))) + +(defun sldb-invoke-restart (&optional number) + "Invoke a restart. +Optional NUMBER specifies the restart to invoke, otherwise +use the restart at point." + (interactive) + (let ((restart (or number (sldb-restart-at-point)))) + (slime-rex () + ((list 'swank:invoke-nth-restart-for-emacs sldb-level restart)) + ((:ok value) (message "Restart returned: %s" value)) + ((:abort))))) + +(defun sldb-break-with-default-debugger () + "Enter default debugger." + (interactive) + (slime-rex () + ('(swank:sldb-break-with-default-debugger) nil slime-current-thread) + ((:abort)))) + +(defun sldb-step () + "Select the \"continue\" restart and set a new break point." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-step ,frame)))) + +(defun sldb-next () + "Select the \"continue\" restart and set a new break point." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-next ,frame)))) + +(defun sldb-out () + "Select the \"continue\" restart and set a new break point." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-out ,frame)))) + +(defun sldb-break-on-return () + "Set a breakpoint at the current frame. +The debugger is entered when the frame exits." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-break-on-return ,frame) + (lambda (msg) (message "%s" msg))))) + +(defun sldb-break (name) + "Set a breakpoint at the start of the function NAME." + (interactive (list (slime-read-symbol-name "Function: " t))) + (slime-eval-async `(swank:sldb-break ,name) + (lambda (msg) (message "%s" msg)))) + +(defun sldb-return-from-frame (string) + "Reads an expression in the minibuffer and causes the function to +return that value, evaluated in the context of the frame." + (interactive (list (slime-read-from-minibuffer "Return from frame: "))) + (let* ((number (sldb-frame-number-at-point))) + (slime-rex () + ((list 'swank:sldb-return-from-frame number string)) + ((:ok value) (message "%s" value)) + ((:abort))))) + +(defun sldb-restart-frame () + "Causes the frame to restart execution with the same arguments as it +was called originally." + (interactive) + (let* ((number (sldb-frame-number-at-point))) + (slime-rex () + ((list 'swank:restart-frame number)) + ((:ok value) (message "%s" value)) + ((:abort))))) + + +;;;; Thread control panel + +(defun slime-list-threads () + "Display a list of threads." + (interactive) + (slime-eval-async + '(swank:list-threads) + (lambda (threads) + (with-current-buffer (get-buffer-create "*slime-threads*") + (slime-thread-control-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (loop for idx from 0 + for (name status id) in threads + do (slime-thread-insert idx name status id)) + (goto-char (point-min)) + (setq buffer-read-only t) + (pop-to-buffer (current-buffer))))))) + +(defun slime-thread-insert (idx name summary id) + (slime-propertize-region `(thread-id ,idx) + (insert (format "%3s: " id)) + (slime-insert-propertized '(face bold) name) + (insert-char ?\ (- 30 (current-column))) + (let ((summary-start (point))) + (insert " " summary) + (unless (bolp) (insert "\n")) + (indent-rigidly summary-start (point) 2)))) + + +;;;;; Major mode + +(define-derived-mode slime-thread-control-mode fundamental-mode + "thread-control" + "SLIME Thread Control Panel Mode. + +\\{slime-thread-control-mode-map}" + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +(slime-define-keys slime-thread-control-mode-map + ("a" 'slime-thread-attach) + ("d" 'slime-thread-debug) + ("g" 'slime-list-threads) + ("k" 'slime-thread-kill) + ("q" 'slime-thread-quit)) + +(defun slime-thread-quit () + (interactive) + (slime-eval-async `(swank:quit-thread-browser)) + (kill-buffer (current-buffer))) + +(defun slime-thread-kill () + (interactive) + (let ((id (get-text-property (point) 'thread-id))) + (slime-eval `(swank:kill-nth-thread ,id))) + (call-interactively 'slime-list-threads)) + +(defun slime-thread-attach () + (interactive) + (let ((id (get-text-property (point) 'thread-id)) + (file (slime-swank-port-file))) + (slime-eval-async `(swank:start-swank-server-in-thread ,id ,file))) + (slime-read-port-and-connect nil nil)) + +(defun slime-thread-debug () + (interactive) + (let ((id (get-text-property (point) 'thread-id))) + (slime-eval-async `(swank:debug-nth-thread ,id)))) + + +;;;;; Connection listing + +(define-derived-mode slime-connection-list-mode fundamental-mode + "connection-list" + "SLIME Connection List Mode. + +\\{slime-connection-list-mode-map}" + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +(slime-define-keys slime-connection-list-mode-map + ((kbd "RET") 'slime-goto-connection) + ("d" 'slime-connection-list-make-default) + ("g" 'slime-update-connection-list) + ((kbd "C-k") 'slime-quit-connection-at-point) + ("R" 'slime-restart-connection-at-point)) + +(defun slime-connection-at-point () + (or (get-text-property (point) 'slime-connection) + (error "No connection at point"))) + +(defun slime-goto-connection () + "Switch to the REPL buffer for the connection at point." + (interactive) + (let ((slime-dispatching-connection (slime-connection-at-point))) + (switch-to-buffer (slime-output-buffer)))) + +(defun slime-quit-connection-at-point (connection) + (interactive (list (slime-connection-at-point))) + (let ((slime-dispatching-connection connection)) + (slime-quit-lisp) + (while (memq connection slime-net-processes) + (sit-for 0 100))) + (slime-update-connection-list)) + +(defun slime-restart-connection-at-point (connection) + (interactive (list (slime-connection-at-point))) + (let ((slime-dispatching-connection connection)) + (slime-restart-inferior-lisp))) + +(defun slime-connection-list-make-default () + "Make the connection at point the default connection." + (interactive) + (slime-select-connection (slime-connection-at-point)) + (slime-update-connection-list)) + +(defun slime-list-connections () + "Display a list of all connections." + (interactive) + (when (get-buffer "*SLIME connections*") + (kill-buffer "*SLIME connections*")) + (with-current-buffer + (slime-get-temp-buffer-create "*SLIME connections*" + :mode 'slime-connection-list-mode) + (slime-draw-connection-list) + (setq buffer-read-only t) + (pop-to-buffer (current-buffer)))) + +(defun slime-update-connection-list () + "Display a list of all connections." + (interactive) + (let ((pos (point)) + (inhibit-read-only t)) + (erase-buffer) + (slime-draw-connection-list) + (goto-char pos))) + +(defun slime-draw-connection-list () + (let ((default-pos nil) + (default slime-default-connection) + (fstring "%s%2s %-10s %-17s %-7s %-s\n")) + (insert (format fstring " " "Nr" "Name" "Port" "Pid" "Type") + (format fstring " " "--" "----" "----" "---" "----")) + (dolist (p (reverse slime-net-processes)) + (when (eq default p) (setf default-pos (point))) + (slime-insert-propertized + (list 'slime-connection p) + (format fstring + (if (eq default p) "*" " ") + (slime-connection-number p) + (slime-connection-name p) + (or (process-id p) (process-contact p)) + (slime-pid p) + (slime-lisp-implementation-type p)))) + (when default + (goto-char default-pos)))) + + +;;;; Inspector + +(defgroup slime-inspector nil + "Inspector faces." + :prefix "slime-inspector-" + :group 'slime) + +(defface slime-inspector-topline-face + '((t ())) + "Face for top line describing object." + :group 'slime-inspector) + +(defface slime-inspector-label-face + '((t (:inherit font-lock-constant-face))) + "Face for labels in the inspector." + :group 'slime-inspector) + +(defface slime-inspector-value-face + (if (slime-face-inheritance-possible-p) + '((t (:inherit font-lock-builtin-face))) + '((((background light)) (:foreground "MediumBlue" :bold t)) + (((background dark)) (:foreground "LightGray" :bold t)))) + "Face for things which can themselves be inspected." + :group 'slime-inspector) + +(defface slime-inspector-action-face + (if (slime-face-inheritance-possible-p) + '((t (:inherit font-lock-warning-face))) + '((t (:foreground "OrangeRed")))) + "Face for labels of inspector actions." + :group 'slime-inspector) + +(defface slime-inspector-type-face + '((t (:inherit font-lock-type-face))) + "Face for type description in inspector." + :group 'slime-inspector) + +(defvar slime-inspector-mark-stack '()) +(defvar slime-saved-window-config) + +(defun slime-inspect (string) + "Eval an expression and inspect the result." + (interactive + (list (slime-read-from-minibuffer "Inspect value (evaluated): " + (slime-sexp-at-point)))) + (slime-eval-async `(swank:init-inspector ,string) 'slime-open-inspector)) + +(define-derived-mode slime-inspector-mode fundamental-mode "Slime-Inspector" + (set-syntax-table lisp-mode-syntax-table) + (slime-set-truncate-lines) + (setq buffer-read-only t)) + +(defun slime-inspector-buffer () + (or (get-buffer "*Slime Inspector*") + (with-current-buffer (get-buffer-create "*Slime Inspector*") + (setq slime-inspector-mark-stack '()) + (slime-mode t) + (slime-inspector-mode) + (make-local-variable 'slime-saved-window-config) + (setq slime-saved-window-config (current-window-configuration)) + (current-buffer)))) + +(defmacro slime-inspector-fontify (face string) + `(slime-add-face ',(intern (format "slime-inspector-%s-face" face)) ,string)) + +(defun slime-open-inspector (inspected-parts &optional point) + "Display INSPECTED-PARTS in a new inspector window. +Optionally set point to POINT." + (with-current-buffer (slime-inspector-buffer) + (setq slime-buffer-connection (slime-current-connection)) + (let ((inhibit-read-only t)) + (erase-buffer) + (destructuring-bind (&key title type content) inspected-parts + (macrolet ((fontify (face string) + `(slime-inspector-fontify ,face ,string))) + (insert (fontify topline title)) + (while (eq (char-before) ?\n) + (backward-delete-char 1)) + (insert "\n [" (fontify label "type:") " " (fontify type type) "]\n" + (fontify label "--------------------") "\n") + (save-excursion + (mapc #'slime-inspector-insert-ispec content)) + (pop-to-buffer (current-buffer)) + (when point + (check-type point cons) + (ignore-errors + (goto-line (car point)) + (move-to-column (cdr point))))))))) + +(defun slime-inspector-insert-ispec (ispec) + (if (stringp ispec) + (insert ispec) + (destructure-case ispec + ((:value string id) + (slime-propertize-region + (list 'slime-part-number id + 'mouse-face 'highlight + 'face 'slime-inspector-value-face) + (insert string))) + ((:action string id) + (slime-insert-propertized (list 'slime-action-number id + 'mouse-face 'highlight + 'face 'slime-inspector-action-face) + string))))) + +(defun slime-inspector-position () + "Return a pair (Y-POSITION X-POSITION) representing the +position of point in the current buffer." + ;; We make sure we return absolute coordinates even if the user has + ;; narrowed the buffer. + (save-restriction + (widen) + (cons (cond ((fboundp 'line-number) + (line-number)) ; XEmacs + ((fboundp 'line-number-at-pos) + (line-number-at-pos)) ; Recent GNU Emacs + (t (1+ (count-lines 1 (point-at-bol))))) + (current-column)))) + +(defun slime-inspector-operate-on-point () + "If point is on a value then recursivly call the inspector on + that value. If point is on an action then call that action." + (interactive) + (let ((part-number (get-text-property (point) 'slime-part-number)) + (action-number (get-text-property (point) 'slime-action-number)) + (opener (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (when parts + (slime-open-inspector parts point)))))) + (cond (part-number + (slime-eval-async `(swank:inspect-nth-part ,part-number) + opener) + (push (slime-inspector-position) slime-inspector-mark-stack)) + (action-number + (slime-eval-async `(swank::inspector-call-nth-action ,action-number) + opener))))) + +(defun slime-inspector-operate-on-click (event) + "Inspect the value at the clicked-at position or invoke an action." + (interactive "@e") + (let ((point (posn-point (event-end event)))) + (cond ((and point + (or (get-text-property point 'slime-part-number) + (get-text-property point 'slime-action-number))) + (goto-char point) + (slime-inspector-operate-on-point)) + (t + (error "No clickable part here"))))) + +(defun slime-inspector-copy-down (number) + "Evaluate the slot at point via the REPL (to set `*')." + (interactive (list (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-repl-send-string (format "%s" `(swank:inspector-nth-part ,number))) + (slime-repl)) + +(defun slime-inspector-pop () + (interactive) + (slime-eval-async + `(swank:inspector-pop) + (lambda (result) + (cond (result + (slime-open-inspector result (pop slime-inspector-mark-stack))) + (t + (message "No previous object") + (ding)))))) + +(defun slime-inspector-next () + (interactive) + (let ((result (slime-eval `(swank:inspector-next)))) + (cond (result + (push (slime-inspector-position) slime-inspector-mark-stack) + (slime-open-inspector result)) + (t (message "No next object") + (ding))))) + +(defun slime-inspector-quit () + (interactive) + (slime-eval-async `(swank:quit-inspector)) + (set-window-configuration slime-saved-window-config) + (kill-buffer (current-buffer))) + +(defun slime-find-inspectable-object (direction limit) + "Finds the next or previous inspectable object within the +current buffer, depending on whether DIRECTION is 'NEXT or +'PREV. LIMIT is the maximum or minimum position in the current +buffer. + +Returns a list of two values: If an object could be found, the +starting position of the found object and T is returned; +otherwise LIMIT and NIL is returned. +" + (let ((finder (ecase direction + (next 'next-single-property-change) + (prev 'previous-single-property-change)))) + (let ((prop nil) (curpos (point))) + (while (and (not prop) (not (= curpos limit))) + (let ((newpos (funcall finder curpos 'slime-part-number nil limit))) + (setq prop (get-text-property newpos 'slime-part-number)) + (setq curpos newpos))) + (list curpos (and prop t))))) + +(defun slime-inspector-next-inspectable-object (arg) + "Move point to the next inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move backwards." + (interactive "p") + (let ((maxpos (point-max)) (minpos (point-min)) + (previously-wrapped-p nil)) + ;; Forward. + (while (> arg 0) + (destructuring-bind (pos foundp) + (slime-find-inspectable-object 'next maxpos) + (if foundp + (progn (goto-char pos) (setq arg (1- arg)) + (setq previously-wrapped-p nil)) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char minpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))) + ;; Backward. + (while (< arg 0) + (destructuring-bind (pos foundp) + (slime-find-inspectable-object 'prev minpos) + ;; SLIME-OPEN-INSPECTOR inserts the title of an inspector page + ;; as a presentation at the beginning of the buffer; skip + ;; that. (Notice how this problem can not arise in ``Forward.'') + (if (and foundp (/= pos minpos)) + (progn (goto-char pos) (setq arg (1+ arg)) + (setq previously-wrapped-p nil)) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char maxpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))))) + + +(defun slime-inspector-previous-inspectable-object (arg) + "Move point to the previous inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move forwards." + (interactive "p") + (slime-inspector-next-inspectable-object (- arg))) + +(defun slime-inspector-describe () + (interactive) + (slime-eval-describe `(swank:describe-inspectee))) + +(defun slime-inspector-pprint (part) + (interactive (list (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-eval-describe `(swank:pprint-inspector-part ,part))) + +(defun slime-inspector-reinspect () + (interactive) + (slime-eval-async `(swank:inspector-reinspect) + (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (slime-open-inspector parts point))))) + +(slime-define-keys slime-inspector-mode-map + ([return] 'slime-inspector-operate-on-point) + ([(meta return)] 'slime-inspector-copy-down) + ("\C-m" 'slime-inspector-operate-on-point) + ([mouse-2] 'slime-inspector-operate-on-click) + ("l" 'slime-inspector-pop) + ("n" 'slime-inspector-next) + (" " 'slime-inspector-next) + ("d" 'slime-inspector-describe) + ("p" 'slime-inspector-pprint) + ("q" 'slime-inspector-quit) + ("g" 'slime-inspector-reinspect) + ("\C-i" 'slime-inspector-next-inspectable-object) + ([(shift tab)] 'slime-inspector-previous-inspectable-object) ; Emacs translates S-TAB + ([backtab] 'slime-inspector-previous-inspectable-object) ; to BACKTAB on X. + ("\M-." 'slime-edit-definition)) + + +;;;; Buffer selector + +(defvar slime-selector-methods nil + "List of buffer-selection methods for the `slime-select' command. +Each element is a list (KEY DESCRIPTION FUNCTION). +DESCRIPTION is a one-line description of what the key selects.") + +(defun slime-selector () + "Select a new buffer by type, indicated by a single character. +The user is prompted for a single character indicating the method by +which to choose a new buffer. The `?' character describes the +available methods. + +See `def-slime-selector-method' for defining new methods." + (interactive) + (message "Select [%s]: " + (apply #'string (mapcar #'car slime-selector-methods))) + (let* ((ch (save-window-excursion + (select-window (minibuffer-window)) + (read-char))) + (method (find ch slime-selector-methods :key #'car))) + (cond ((null method) + (message "No method for character: ?\\%c" ch) + (ding) + (sleep-for 1) + (discard-input) + (slime-selector)) + (t + (funcall (third method)))))) + +(defmacro def-slime-selector-method (key description &rest body) + "Define a new `slime-select' buffer selection method. + +KEY is the key the user will enter to choose this method. + +DESCRIPTION is a one-line sentence describing how the method +selects a buffer. + +BODY is a series of forms which are evaluated when the selector +is chosen. The returned buffer is selected with +switch-to-buffer." + `(setq slime-selector-methods + (sort* (cons (list ,key ,description + (lambda () + (let ((buffer (progn ,@body))) + (cond ((get-buffer buffer) + (switch-to-buffer buffer)) + (t + (message "No such buffer: %S" buffer) + (ding)))))) + (remove* ,key slime-selector-methods :key #'car)) + #'< :key #'car))) + +(def-slime-selector-method ?? "Selector help buffer." + (ignore-errors (kill-buffer "*Select Help*")) + (with-current-buffer (get-buffer-create "*Select Help*") + (insert "Select Methods:\n\n") + (loop for (key line function) in slime-selector-methods + do (insert (format "%c:\t%s\n" key line))) + (help-mode) + (display-buffer (current-buffer) t) + (shrink-window-if-larger-than-buffer + (get-buffer-window (current-buffer)))) + (slime-selector) + (current-buffer)) + +(def-slime-selector-method ?r + "SLIME Read-Eval-Print-Loop." + (cond ((slime-current-connection) + (slime-output-buffer)) + ((y-or-n-p "No connection: start Slime? ") + (slime)))) + +(def-slime-selector-method ?i + "*inferior-lisp* buffer." + (cond ((and (slime-connected-p) (slime-process)) + (process-buffer (slime-process))) + (t + "*inferior-lisp*"))) + +(def-slime-selector-method ?v + "*slime-events* buffer." + slime-event-buffer-name) + +(def-slime-selector-method ?l + "most recently visited lisp-mode buffer." + (slime-recently-visited-buffer 'lisp-mode)) + +(def-slime-selector-method ?d + "*sldb* buffer for the current connection." + (or (sldb-get-default-buffer) + (error "No debugger buffer"))) + +(def-slime-selector-method ?e + "most recently visited emacs-lisp-mode buffer." + (slime-recently-visited-buffer 'emacs-lisp-mode)) + +(def-slime-selector-method ?c + "SLIME connections buffer." + (slime-list-connections) + "*SLIME connections*") + +(def-slime-selector-method ?t + "SLIME threads buffer." + (slime-list-threads) + (slime-eval `(cl:quote nil)) ;wait until slime-list-threads returns + "*slime-threads*") + +(defun slime-recently-visited-buffer (mode) + "Return the most recently visited buffer whose major-mode is MODE. +Only considers buffers that are not already visible." + (loop for buffer in (buffer-list) + when (and (with-current-buffer buffer (eq major-mode mode)) + (not (string-match "^ " (buffer-name buffer))) + (null (get-buffer-window buffer 'visible))) + return buffer + finally (error "Can't find unshown buffer in %S" mode))) + + +;;;; Editing commands + + + +;;;; Font Lock + +(defcustom slime-highlight-suppressed-forms t + "Display forms disabled by reader conditionals as comments." + :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) + :group 'slime-mode) + +(defface slime-reader-conditional-face + (if (slime-face-inheritance-possible-p) + '((t (:inherit font-lock-comment-face))) + '((((background light)) (:foreground "DimGray" :bold t)) + (((background dark)) (:foreground "LightGray" :bold t)))) + "Face for compiler notes while selected." + :group 'slime-mode-faces) + +(defun slime-search-suppressed-forms (limit) + "Find reader conditionalized forms where the test is false." + (when (and slime-highlight-suppressed-forms + (slime-connected-p) + (re-search-forward "^\$[^;\n]*?[ \t(]\$?#[-+]" limit t)) + (ignore-errors + (let* ((start (- (point) 2)) + (char (char-before)) + (e (read (current-buffer))) + (val (slime-eval-feature-conditional e))) + (when (<= (point) limit) + (if (or (and (eq char ?+) (not val)) + (and (eq char ?-) val)) + (progn + (forward-sexp) (backward-sexp) + (slime-forward-sexp) + (assert (<= (point) limit)) + (let ((md (match-data))) + (fill md nil) + (setf (first md) start) + (setf (second md) (point)) + (set-match-data md) + t)) + (slime-search-suppressed-forms limit))))))) + +(defun slime-activate-font-lock-magic () + (if (featurep 'xemacs) + (let ((pattern `((slime-search-suppressed-forms + (0 slime-reader-conditional-face t))))) + (dolist (sym '(lisp-font-lock-keywords + lisp-font-lock-keywords-1 + lisp-font-lock-keywords-2)) + (set sym (append (symbol-value sym) pattern)))) + (font-lock-add-keywords + 'lisp-mode + `((slime-search-suppressed-forms 0 ,''slime-reader-conditional-face t))))) + +(when slime-highlight-suppressed-forms + (slime-activate-font-lock-magic)) + + +;;;; Indentation + +(defun slime-update-indentation () + "Update indentation for all macros defined in the Lisp system." + (interactive) + (slime-eval-async '(swank:update-indentation-information))) + +(defvar slime-indentation-update-hooks) + +(defun slime-handle-indentation-update (alist) + "Update Lisp indent information. + +ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation +settings for `common-lisp-indent-function'. The appropriate property +is setup, unless the user already set one explicitly." + (dolist (info alist) + (let ((symbol (intern (car info))) + (indent (cdr info))) + ;; Does the symbol have an indentation value that we set? + (when (equal (get symbol 'common-lisp-indent-function) + (get symbol 'slime-indent)) + (put symbol 'slime-indent indent) + (put symbol 'common-lisp-indent-function indent)) + (run-hook-with-args 'slime-indentation-update-hooks symbol indent)))) + + +;;;;; Pull-down menu + +(defvar slime-easy-menu + (let ((C '(slime-connected-p))) + `("SLIME" + [ "Edit Definition..." slime-edit-definition ,C ] + [ "Return From Definition" slime-pop-find-definition-stack ,C ] + [ "Complete Symbol" slime-complete-symbol ,C ] + [ "Show REPL" slime-switch-to-output-buffer ,C ] + "--" + ("Evaluation" + [ "Eval Defun" slime-eval-defun ,C ] + [ "Eval Last Expression" slime-eval-last-expression ,C ] + [ "Eval And Pretty-Print" slime-pprint-eval-last-expression ,C ] + [ "Eval Region" slime-eval-region ,C ] + [ "Interactive Eval..." slime-interactive-eval ,C ] + [ "Edit Lisp Value..." slime-edit-value ,C ] + [ "Call Defun" slime-call-defun ,C ]) + ("Debugging" + [ "Macroexpand Once..." slime-macroexpand-1 ,C ] + [ "Macroexpand All..." slime-macroexpand-all ,C ] + [ "Create Trace Buffer" slime-redirect-trace-output ,C ] + [ "Toggle Trace..." slime-toggle-trace-fdefinition ,C ] + [ "Untrace All" slime-untrace-all ,C] + [ "Disassemble..." slime-disassemble-symbol ,C ] + [ "Inspect..." slime-inspect ,C ]) + ("Compilation" + [ "Compile Defun" slime-compile-defun ,C ] + [ "Compile/Load File" slime-compile-and-load-file ,C ] + [ "Compile File" slime-compile-file ,C ] + [ "Compile Region" slime-compile-region ,C ] + "--" + [ "Next Note" slime-next-note t ] + [ "Previous Note" slime-previous-note t ] + [ "Remove Notes" slime-remove-notes t ] + [ "List Notes" slime-list-compiler-notes ,C ]) + ("Cross Reference" + [ "Who Calls..." slime-who-calls ,C ] + [ "Who References... " slime-who-references ,C ] + [ "Who Sets..." slime-who-sets ,C ] + [ "Who Binds..." slime-who-binds ,C ] + [ "Who Macroexpands..." slime-who-macroexpands ,C ] + [ "Who Specializes..." slime-who-specializes ,C ] + [ "List Callers..." slime-list-callers ,C ] + [ "List Callees..." slime-list-callees ,C ] + [ "Next Location" slime-next-location t ]) + ("Editing" + [ "Check Parens" check-parens t] + [ "Update Indentation" slime-update-indentation ,C] + [ "Select Buffer" slime-selector t]) + ("Profiling" + [ "Toggle Profiling..." slime-toggle-profile-fdefinition ,C ] + [ "Profile Package" slime-profile-package ,C] + [ "Unprofile All" slime-unprofile-all ,C ] + [ "Show Profiled" slime-profiled-functions ,C ] + "--" + [ "Report" slime-profile-report ,C ] + [ "Reset Counters" slime-profile-reset ,C ]) + ("Documentation" + [ "Describe Symbol..." slime-describe-symbol ,C ] + [ "Apropos..." slime-apropos ,C ] + [ "Apropos all..." slime-apropos-all ,C ] + [ "Apropos Package..." slime-apropos-package ,C ] + [ "Hyperspec..." slime-hyperspec-lookup t ]) + "--" + [ "Interrupt Command" slime-interrupt ,C ] + [ "Abort Async. Command" slime-quit ,C ] + [ "Sync Package & Directory" slime-sync-package-and-default-directory ,C] + [ "Set Package in REPL" slime-repl-set-package ,C]))) + +(defvar slime-repl-easy-menu + (let ((C '(slime-connected-p))) + `("REPL" + [ "Send Input" slime-repl-return ,C ] + [ "Close and Send Input " slime-repl-closing-return ,C ] + [ "Interrupt Lisp process" slime-interrupt ,C ] + "--" + [ "Previous Input" slime-repl-previous-input t ] + [ "Next Input" slime-repl-next-input t ] + [ "Goto Previous Prompt " slime-repl-previous-prompt t ] + [ "Goto Next Prompt " slime-repl-next-prompt t ] + [ "Clear Last Output" slime-repl-clear-output t ] + [ "Clear Buffer " slime-repl-clear-buffer t ] + [ "Kill Current Input" slime-repl-kill-input t ]))) + +(defvar slime-sldb-easy-menu + (let ((C '(slime-connected-p))) + `("SLDB" + [ "Next Frame" sldb-down t ] + [ "Previous Frame" sldb-up t ] + [ "Toggle Frame Details" sldb-toggle-details t ] + [ "Next Frame (Details)" sldb-details-down t ] + [ "Previous Frame (Details)" sldb-details-up t ] + "--" + [ "Eval Expression..." slime-interactive-eval ,C ] + [ "Eval in Frame..." sldb-eval-in-frame ,C ] + [ "Eval in Frame (pretty print)..." sldb-pprint-eval-in-frame ,C ] + [ "Inspect In Frame..." sldb-inspect-in-frame ,C ] + [ "Inspect Condition Object" sldb-inspect-condition ,C ] + [ "Print Condition to REPL" sldb-print-condition t ] + "--" + [ "Restart Frame" sldb-restart-frame ,C ] + [ "Return from Frame..." sldb-return-from-frame ,C ] + ("Invoke Restart" + [ "Continue" sldb-continue ,C ] + [ "Abort" sldb-abort ,C ] + [ "Step" sldb-step ,C ] + [ "Step next" sldb-next ,C ] + [ "Step out" sldb-out ,C ] + ) + "--" + [ "Quit (throw)" sldb-quit ,C ] + [ "Break With Default Debugger" sldb-break-with-default-debugger ,C ]))) + +(easy-menu-define menubar-slime slime-mode-map "SLIME" slime-easy-menu) + +(defun slime-add-easy-menu () + (easy-menu-add slime-easy-menu 'slime-mode-map)) + +(add-hook 'slime-mode-hook 'slime-add-easy-menu) + +(defun slime-repl-add-easy-menu () + (easy-menu-define menubar-slime-repl slime-repl-mode-map + "REPL" slime-repl-easy-menu) + (easy-menu-define menubar-slime slime-repl-mode-map + "SLIME" slime-easy-menu) + (easy-menu-add slime-repl-easy-menu 'slime-repl-mode-map)) + +(add-hook 'slime-repl-mode-hook 'slime-repl-add-easy-menu) + +(defun slime-sldb-add-easy-menu () + (easy-menu-define menubar-slime-sldb + sldb-mode-map "SLDB" slime-sldb-easy-menu) + (easy-menu-add slime-sldb-easy-menu 'sldb-mode-map)) + +(add-hook 'sldb-mode-hook 'slime-sldb-add-easy-menu) + + +;;;; Cheat Sheet + +(defvar slime-cheat-sheet-table + '((:title "Editing lisp code" + :map slime-mode-map + :bindings ((slime-eval-defun "Evaluate current top level form") + (slime-compile-defun "Compile current top level form") + (slime-interactive-eval "Prompt for form and eval it") + (slime-compile-and-load-file "Compile and load current file") + (slime-sync-package-and-default-directory "Synch default package and directory with current buffer") + (slime-next-note "Next compiler note") + (slime-previous-note "Previous compiler note") + (slime-remove-notes "Remove notes") + slime-hyperspec-lookup)) + (:title "Completion" + :map slime-mode-map + :bindings (slime-indent-and-complete-symbol + slime-fuzzy-complete-symbol)) + (:title "At the REPL" + :map slime-repl-mode-map + :bindings (slime-repl-clear-buffer + slime-describe-symbol)) + (:title "Within SLDB buffers" + :map sldb-mode-map + :bindings ((sldb-default-action "Do 'whatever' with thing at point") + (sldb-toggle-details "Toggle frame details visualization") + (sldb-quit "Quit to REPL") + (sldb-abort "Invoke ABORT restart") + (sldb-continue "Invoke CONTINUE restart (if available)") + (sldb-show-source "Jump to frame's source code") + (sldb-eval-in-frame "Evaluate in frame at point") + (sldb-inspect-in-frame "Evaluate in frame at point and inspect result"))) + (:title "Within the Inspector" + :map slime-inspector-mode-map + :bindings ((slime-inspector-next-inspectable-object "Jump to next inspectable object") + (slime-inspector-operate-on-point "Inspect object or execute action at point") + (slime-inspector-reinspect "Reinspect current object") + (slime-inspector-pop "Return to previous object") + (slime-inspector-copy-down "Send object at point to REPL") + (slime-inspector-quit "Quit"))) + (:title "Finding Definitions" + :map slime-mode-map + :bindings (slime-edit-definition + slime-pop-find-definition-stack)))) + +(defun slime-cheat-sheet () + (interactive) + (switch-to-buffer-other-frame (get-buffer-create "*SLIME Cheat Sheet*")) + (setq buffer-read-only nil) + (delete-region (point-min) (point-max)) + (goto-char (point-min)) + (insert "SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode).\n\n") + (dolist (mode slime-cheat-sheet-table) + (let ((title (getf mode :title)) + (mode-map (getf mode :map)) + (mode-keys (getf mode :bindings))) + (insert title) + (insert ":\n") + (insert (make-string (1+ (length title)) ?-)) + (insert "\n") + (let ((keys '()) + (descriptions '())) + (dolist (func mode-keys) + ;; func is eithor the function name or a list (NAME DESCRIPTION) + (push (if (symbolp func) + (prin1-to-string func) + (second func)) + descriptions) + (let ((all-bindings (where-is-internal (if (symbolp func) + func + (first func)) + (symbol-value mode-map))) + (key-bindings '())) + (dolist (binding all-bindings) + (when (and (vectorp binding) + (integerp (aref binding 0))) + (push binding key-bindings))) + (push (mapconcat 'key-description key-bindings " or ") keys))) + (loop + with key-length = (apply 'max (mapcar 'length keys)) + with desc-length = (apply 'max (mapcar 'length descriptions)) + for key in (nreverse keys) + for desc in (nreverse descriptions) + do (insert desc) + do (insert (make-string (- desc-length (length desc)) ? )) + do (insert " => ") + do (insert (if (string= "" key) + "<not on any key>" + key)) + do (insert "\n") + finally do (insert "\n"))))) + (setq buffer-read-only t) + (goto-char (point-min))) + + +;;;; Test suite + +(defstruct (slime-test (:conc-name slime-test.)) + name fname args doc inputs fails-for) + +(defvar slime-tests '() + "Names of test functions.") + +(defvar slime-test-debug-on-error nil + "*When non-nil debug errors in test cases.") + +(defvar slime-total-tests nil + "Total number of tests executed during a test run.") + +(defvar slime-failed-tests nil + "Total number of failed tests during a test run.") + +(defvar slime-expected-failures nil + "Total number of expected failures during a test run") + +(defvar slime-test-buffer-name "*Tests*" + "The name of the buffer used to display test results.") + + +;; dynamically bound during a single test +(defvar slime-current-test) +(defvar slime-unexpected-failures) + + +;;;;; Execution engine + +(defun slime-run-tests () + "Run the test suite. +The results are presented in an outline-mode buffer, with the tests +that succeeded initially folded away." + (interactive) + (assert (not (slime-busy-p))) + (slime-create-test-results-buffer) + (unwind-protect + (slime-execute-tests) + (pop-to-buffer slime-test-buffer-name) + (goto-char (point-min)) + (hide-body) + ;; Expose failed tests + (dolist (o (overlays-in (point-min) (point-max))) + (when (overlay-get o 'slime-failed-test) + (goto-char (overlay-start o)) + (show-subtree))))) + +(defun slime-run-one-test (name) + "Ask for the name of a test and then execute the test." + (interactive (list (slime-read-test-name))) + (let ((test (find name slime-tests :key #'slime-test.name))) + (assert test) + (let ((slime-tests (list test))) + (slime-run-tests)))) + +(defun slime-read-test-name () + (let ((alist (mapcar (lambda (test) + (list (symbol-name (slime-test.name test)))) + slime-tests))) + (read (completing-read "Test: " alist nil t)))) + +(defun slime-test-should-fail-p (test) + (member (slime-lisp-implementation-name) + (slime-test.fails-for test))) + +(defun slime-execute-tests () + "Execute each test case with each input. +Return the number of failed tests." + (save-window-excursion + (let ((slime-total-tests 0) + (slime-expected-passes 0) + (slime-unexpected-failures 0) + (slime-expected-failures 0)) + (dolist (slime-current-test slime-tests) + (with-struct (slime-test. name (function fname) inputs) + slime-current-test + (slime-test-heading 1 "%s" name) + (dolist (input inputs) + (incf slime-total-tests) + (message "%s: %s" name input) + (slime-test-heading 2 "input: %s" input) + (if slime-test-debug-on-error + (let ((debug-on-error t) + (debug-on-quit t)) + (apply function input)) + (condition-case err + (apply function input) + (error + (cond ((slime-test-should-fail-p slime-current-test) + (incf slime-expected-failures) + (slime-test-failure "ERROR (expected)" + (format "%S" err))) + (t + (incf slime-unexpected-failures) + (slime-print-check-error err))))))))) + (let ((summary (cond ((and (zerop slime-expected-failures) + (zerop slime-unexpected-failures)) + (format "All %S tests completed successfully." + slime-total-tests)) + (t + (format "Failed on %S (%S expected) of %S tests." + (+ slime-expected-failures + slime-unexpected-failures) + slime-expected-failures + slime-total-tests))))) + (save-excursion + (with-current-buffer slime-test-buffer-name + (goto-char (point-min)) + (insert summary "\n\n"))) + (message "%s" summary) + slime-unexpected-failures)))) + +(defun slime-batch-test (results-file) + "Run the test suite in batch-mode. +Exits Emacs when finished. The exit code is the number of failed tests." + (let ((slime-test-debug-on-error nil)) + (slime) + ;; Block until we are up and running. + (while (not (slime-connected-p)) + (sit-for 1)) + (slime-sync-to-top-level 5) + (switch-to-buffer "*scratch*") + (let ((failed-tests (slime-run-tests))) + (with-current-buffer slime-test-buffer-name + (slime-delete-hidden-outline-text) + (goto-char (point-min)) + (insert "-*- outline -*-\n\n") + (write-file results-file)) + (kill-emacs failed-tests)))) + + +;;;;; Results buffer creation and output + +(defun slime-create-test-results-buffer () + "Create and initialize the buffer for test suite results." + (ignore-errors (kill-buffer slime-test-buffer-name)) + (with-current-buffer (get-buffer-create slime-test-buffer-name) + (erase-buffer) + (outline-mode) + (set (make-local-variable 'outline-regexp) "\\*+") + (slime-set-truncate-lines))) + +(defun slime-delete-hidden-outline-text () + "Delete the hidden parts of an outline-mode buffer." + (loop do (when (eq (get-char-property (point) 'invisible) 'outline) + (delete-region (point) + (next-single-char-property-change (point) + 'invisible))) + until (eobp) + do (goto-char (next-single-char-property-change (point) 'invisible)))) + +(defun slime-test-heading (level format &rest args) + "Output a test suite heading. +LEVEL gives the depth of nesting: 1 for top-level, 2 for a subheading, etc." + (with-current-buffer slime-test-buffer-name + (goto-char (point-max)) + (insert (make-string level ?*) + " " + (apply 'format format args) + "\n"))) + +(defun slime-test-failure (keyword string) + "Output a failure message from the test suite. +KEYWORD names the type of failure and STRING describes the reason." + (with-current-buffer slime-test-buffer-name + (goto-char (point-max)) + (let ((start (point))) + (insert keyword ": ") + (let ((overlay (make-overlay start (point)))) + (overlay-put overlay 'slime-failed-test t) + (overlay-put overlay 'face 'bold))) + (insert string "\n"))) + +(defun slime-test-message (string) + "Output a message from the test suite." + (with-current-buffer slime-test-buffer-name + (goto-char (point-max)) + (insert string "\n"))) + + +;;;;; Macros for defining test cases + +(defmacro def-slime-test (name args doc inputs &rest body) + "Define a test case. +NAME ::= SYMBOL | (SYMBOL (FAILS-FOR*)) is a symbol naming the test. +ARGS is a lambda-list. +DOC is a docstring. +INPUTS is a list of argument lists, each tested separately. +BODY is the test case. The body can use `slime-check' to test +conditions (assertions)." + (multiple-value-bind (name fails-for) (etypecase name + (symbol (values name '())) + (cons name)) + (let ((fname (intern (format "slime-test-%s" name)))) + `(progn + (defun ,fname ,args + ,doc + (slime-sync) + ,@body) + (setq slime-tests + (append (remove* ',name slime-tests :key 'slime-test.name) + (list (make-slime-test :name ',name :fname ',fname + :fails-for ',fails-for + :inputs ,inputs)))))))) + +(defmacro slime-check (test-name &rest body) + "Check a condition (assertion.) +TEST-NAME can be a symbol, a string, or a (FORMAT-STRING . ARGS) list. +BODY returns true if the check succeeds." + (let ((check-name (gensym "check-name-"))) + `(let ((,check-name ,(typecase test-name + (symbol (symbol-name test-name)) + (string test-name) + (cons `(format ,@test-name))))) + (if (progn ,@body) + (slime-print-check-ok ,check-name) + (cond ((slime-test-should-fail-p slime-current-test) + (incf slime-expected-failures) + (slime-test-failure "FAIL (expected)" ,check-name)) + (t + (incf slime-unexpected-failures) + (slime-print-check-failed ,check-name))) + (when slime-test-debug-on-error + (debug (format "Check failed: %S" ,check-name))))))) + +(defun slime-print-check-ok (test-name) + (slime-test-message test-name)) + +(defun slime-print-check-failed (test-name) + (slime-test-failure "FAILED" test-name)) + +(defun slime-print-check-error (reason) + (slime-test-failure "ERROR" (format "%S" reason))) + +(put 'def-slime-test 'lisp-indent-function 4) +(put 'slime-check 'lisp-indent-function 1) + + +;;;;; Test case definitions + +;; Clear out old tests. +(setq slime-tests nil) + +(defun slime-check-top-level (&optional test-name) + (slime-accept-process-output nil 0.001) + (slime-check "At the top level (no debugging or pending RPCs)" + (slime-at-top-level-p))) + +(defun slime-at-top-level-p () + (and (not (sldb-get-default-buffer)) + (null (slime-rex-continuations)))) + +(defun slime-wait-condition (name predicate timeout) + (let ((end (time-add (current-time) (seconds-to-time timeout)))) + (while (not (funcall predicate)) + (cond ((time-less-p end (current-time)) + (error "Timeout waiting for condition: %S" name)) + (t + ;; XXX if a process-filter enters a recursive-edit, we + ;; hang forever + (save-excursion + (slime-accept-process-output nil 0.1))))))) + +(defun slime-sync-to-top-level (timeout) + (slime-wait-condition "top-level" #'slime-at-top-level-p timeout)) + +;; XXX: unused function +(defun slime-check-sldb-level (expected) + (let ((sldb-level (when-let (sldb (sldb-get-default-buffer)) + (with-current-buffer sldb + sldb-level)))) + (slime-check ("SLDB level (%S) is %S" expected sldb-level) + (equal expected sldb-level)))) + +(defun slime-test-expect (name expected actual &optional test) + (when (stringp expected) (setq expected (substring-no-properties expected))) + (when (stringp actual) (setq actual (substring-no-properties actual))) + (slime-check ("%s:\nexpected: [%S]\n actual: [%S]" name expected actual) + (funcall (or test #'equal) expected actual))) + +(defun sldb-level () + (when-let (sldb (sldb-get-default-buffer)) + (with-current-buffer sldb + sldb-level))) + +(defun slime-sldb-level= (level) + (when-let (sldb (sldb-get-default-buffer)) + (with-current-buffer sldb + (equal sldb-level level)))) + +(def-slime-test narrowing + () + "Check that narrowing is properly sustained." + '(()) + (slime-check-top-level) + (let ((random-buffer-name (symbol-name (gensym))) + (defun-pos) (tmpbuffer)) + (with-temp-buffer + (dotimes (i 100) (insert (format ";;; %d. line\n" i))) + (setq tmpbuffer (current-buffer)) + (setq defun-pos (point)) + (insert (concat "(defun __foo__ (x y)" "\n" + " 'nothing)" "\n")) + (dotimes (i 100) (insert (format ";;; %d. line\n" (+ 100 i)))) + (slime-check "Checking that newly created buffer is not narrowed." + (not (slime-buffer-narrowed-p))) + + (goto-char defun-pos) + (narrow-to-defun) + (slime-check "Checking that narrowing succeeded." + (slime-buffer-narrowed-p)) + + (slime-with-output-to-temp-buffer (random-buffer-name) nil + (slime-check ("Checking that we're in Slime's temp buffer `%s'" random-buffer-name) + (equal (buffer-name (current-buffer)) random-buffer-name)) + (slime-temp-buffer-quit)) + (kill-buffer random-buffer-name) + (slime-check ("Checking that we've got back from `%s'" random-buffer-name) + (and (eq (current-buffer) tmpbuffer) + (= (point) defun-pos))) + + (slime-check "Checking that narrowing sustained after quitting Slime's temp buffer." + (slime-buffer-narrowed-p)) + + (let ((slime-buffer-package "SWANK") + (symbol '*buffer-package*)) + (slime-edit-definition (symbol-name symbol)) + (slime-check ("Checking that we've got M-. into swank.lisp." symbol) + (string= (file-name-nondirectory (buffer-file-name)) + "swank.lisp")) + (slime-pop-find-definition-stack) + (slime-check ("Checking that we've got back.") + (and (eq (current-buffer) tmpbuffer) + (= (point) defun-pos))) + + (slime-check "Checking that narrowing sustained after M-," + (slime-buffer-narrowed-p))) + )) + (slime-check-top-level)) + + +(def-slime-test find-definition + (name buffer-package snippet) + "Find the definition of a function or macro in swank.lisp." + '(("read-from-emacs" "SWANK" "(defun read-from-emacs ") + ("swank::read-from-emacs" "CL-USER" "(defun read-from-emacs ") + ("swank:start-server" "CL-USER" "(defun start-server ")) + (switch-to-buffer "*scratch*") ; not buffer of definition + (slime-check-top-level) + (let ((orig-buffer (current-buffer)) + (orig-pos (point)) + (enable-local-variables nil) ; don't get stuck on -*- eval: -*- + (slime-buffer-package buffer-package)) + (slime-edit-definition name) + ;; Postconditions + (slime-check ("Definition of `%S' is in swank.lisp." name) + (string= (file-name-nondirectory (buffer-file-name)) "swank.lisp")) + (slime-check "Definition now at point." (looking-at snippet)) + (slime-pop-find-definition-stack) + (slime-check "Returning from definition restores original buffer/position." + (and (eq orig-buffer (current-buffer)) + (= orig-pos (point))))) + (slime-check-top-level)) + +(def-slime-test complete-symbol + (prefix expected-completions) + "Find the completions of a symbol-name prefix." + '(("cl:compile" (("cl:compile" "cl:compile-file" "cl:compile-file-pathname" + "cl:compiled-function" "cl:compiled-function-p" "cl:compiler-macro" + "cl:compiler-macro-function") + "cl:compile")) + ("cl:foobar" (nil "")) + ("swank::compile-file" (("swank::compile-file" + "swank::compile-file-for-emacs" + "swank::compile-file-if-needed" + "swank::compile-file-pathname") + "swank::compile-file")) + ("cl:m-v-l" (nil ""))) + (let ((completions (slime-simple-completions prefix))) + (slime-test-expect "Completion set" expected-completions completions))) + +(def-slime-test arglist + ;; N.B. Allegro apparently doesn't return the default values of + ;; optional parameters. Thus the regexp in the start-server + ;; expected value. In a perfect world we'd find a way to smooth + ;; over this difference between implementations--perhaps by + ;; convincing Franz to provide a function that does what we want. + (function-name expected-arglist) + "Lookup the argument list for FUNCTION-NAME. +Confirm that EXPECTED-ARGLIST is displayed." + '(("swank::operator-arglist" "(swank::operator-arglist name package)") + ("swank::create-socket" "(swank::create-socket host port)") + ("swank::emacs-connected" "(swank::emacs-connected )") + ("swank::compile-string-for-emacs" + "(swank::compile-string-for-emacs string buffer position directory)") + ("swank::connection.socket-io" + "(swank::connection.socket-io \$struct\\(ure\$?\\|object\\|instance\\))") + ("cl:lisp-implementation-type" "(cl:lisp-implementation-type )") + ("cl:class-name" + "(cl:class-name \$class\\|object\\|instance\\|structure\$)")) + (slime-check-top-level) + (let ((arglist (slime-eval `(swank:operator-arglist ,function-name + "swank")))) + (slime-test-expect "Argument list is as expected" + expected-arglist (downcase arglist) + #'string-match)) + (slime-check-top-level)) + +(def-slime-test (compile-defun ("allegro" "lispworks" "clisp")) + (program subform) + "Compile PROGRAM containing errors. +Confirm that SUBFORM is correctly located." + '(("(defun cl-user::foo () (cl-user::bar))" (cl-user::bar)) + ("(defun cl-user::foo () + #\\space + ;;Sdf + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + #+(or)skipped + #| #||# + #||# |# + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + (list `(1 ,(random 10) 2 ,@(random 10) 3 ,(cl-user::bar))))" + (cl-user::bar)) + ("(defun cl-user::foo () + \"\\\" bla bla \\\"\" + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + #.*log-events* + (cl-user::bar))" + (cl-user::bar)) + ("#.'(defun x () (/ 1 0)) + (defun foo () + (cl-user::bar)) + + " + (cl-user::bar))) + (slime-check-top-level) + (with-temp-buffer + (lisp-mode) + (insert program) + (setq slime-buffer-package ":swank") + (slime-compile-string (buffer-string) 1) + (setq slime-buffer-package ":cl-user") + (slime-sync-to-top-level 5) + (goto-char (point-max)) + (slime-previous-note) + (slime-check error-location-correct + (equal (read (current-buffer)) + subform))) + (slime-check-top-level)) + +(def-slime-test async-eval-debugging (depth) + "Test recursive debugging of asynchronous evaluation requests." + '((1) (2) (3)) + (slime-check-top-level) + (lexical-let ((depth depth) + (debug-hook-max-depth 0)) + (let ((debug-hook + (lambda () + (with-current-buffer (sldb-get-default-buffer) + (when (> sldb-level debug-hook-max-depth) + (setq debug-hook-max-depth sldb-level) + (if (= sldb-level depth) + ;; We're at maximum recursion - time to unwind + (sldb-quit) + ;; Going down - enter another recursive debug + ;; Recursively debug. + (slime-eval-async 'no-such-variable))))))) + (let ((sldb-hook (cons debug-hook sldb-hook))) + (slime-eval-async 'no-such-variable) + (slime-sync-to-top-level 5) + (slime-check-top-level) + (slime-check ("Maximum depth reached (%S) is %S." + debug-hook-max-depth depth) + (= debug-hook-max-depth depth)))))) + +(def-slime-test unwind-to-previous-sldb-level (level2 level1) + "Test recursive debugging and returning to lower SLDB levels." + '((2 1) (4 2)) + (slime-check-top-level) + (lexical-let ((level2 level2) + (level1 level1) + (state 'enter) + (max-depth 0)) + (let ((debug-hook + (lambda () + (with-current-buffer (sldb-get-default-buffer) + (setq max-depth (max sldb-level max-depth)) + (ecase state + (enter + (cond ((= sldb-level level2) + (setq state 'leave) + (sldb-invoke-restart (sldb-first-abort-restart))) + (t + (slime-eval-async `(cl:aref cl:nil ,sldb-level))))) + (leave + (cond ((= sldb-level level1) + (setq state 'ok) + (sldb-quit)) + (t + (sldb-invoke-restart (sldb-first-abort-restart)) + )))))))) + (let ((sldb-hook (cons debug-hook sldb-hook))) + (slime-eval-async `(cl:aref cl:nil 0)) + (slime-sync-to-top-level 15) + (slime-check-top-level) + (slime-check ("Maximum depth reached (%S) is %S." max-depth level2) + (= max-depth level2)) + (slime-check ("Final state reached.") + (eq state 'ok)))))) + +(defun sldb-first-abort-restart () + (let ((case-fold-search t)) + (position-if (lambda (x) (string-match "abort" (car x))) sldb-restarts))) + +(def-slime-test loop-interrupt-quit + () + "Test interrupting a loop." + '(()) + (slime-check-top-level) + (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER") + (slime-accept-process-output nil 1) + (slime-check "In eval state." (slime-busy-p)) + (slime-interrupt) + (slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5) + (slime-check-top-level)) + +(def-slime-test loop-interrupt-continue-interrupt-quit + () + "Test interrupting a previously interrupted but continued loop." + '(()) + (slime-check-top-level) + (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER") + (sleep-for 1) + (slime-wait-condition "running" #'slime-busy-p 5) + (slime-interrupt) + (slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (slime-wait-condition "running" (lambda () + (and (slime-busy-p) + (not (sldb-get-default-buffer)))) 5) + (slime-interrupt) + (slime-wait-condition "Second interrupt" (lambda () (slime-sldb-level= 1)) 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5) + (slime-check-top-level)) + +(def-slime-test interactive-eval + () + "Test interactive eval and continuing from the debugger." + '(()) + (slime-check-top-level) + (lexical-let ((done nil)) + (let ((sldb-hook (lambda () (sldb-continue) (setq done t)))) + (slime-interactive-eval + "(progn(cerror \"foo\" \"restart\")(cerror \"bar\" \"restart\")(+ 1 2))") + (while (not done) (slime-accept-process-output)) + (slime-sync-to-top-level 5) + (slime-check-top-level) + (let ((message (current-message))) + (slime-check "Minibuffer contains: \"3\"" + (equal "=> 3 (#x3, #o3, #b11)" message)))))) + +(def-slime-test interrupt-bubbling-idiot + () + "Test interrupting a loop that sends a lot of output to Emacs." + '(()) + (slime-accept-process-output nil 1) + (slime-check-top-level) + (slime-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i) + (cl:finish-output))) + (lambda (_) ) + "CL-USER") + (sleep-for 1) + (slime-interrupt) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window (sldb-get-default-buffer)))) + 30) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5)) + +(def-slime-test package-updating + (package-name nicknames) + "Test if slime-lisp-package is updated." + '(("COMMON-LISP" ("CL")) + ("KEYWORD" ("" "KEYWORD")) + ("COMMON-LISP-USER" ("CL-USER"))) + (with-current-buffer (slime-output-buffer) + (let ((p (slime-eval + `(swank:listener-eval + ,(format + "(cl:setq cl:*print-case* :upcase) + (cl:setq cl:*package* (cl:find-package %S)) + (cl:package-name cl:*package*)" package-name)) + (slime-lisp-package)))) + (slime-check ("slime-lisp-package is %S." package-name) + (equal (slime-lisp-package) package-name)) + (slime-check ("slime-lisp-package-prompt-string is in %S." nicknames) + (member (slime-lisp-package-prompt-string) nicknames))))) + +(def-slime-test repl-test + (input result-contents) + "Test simple commands in the minibuffer." + '(("(+ 1 2)" "SWANK> (+ 1 2) +3 +SWANK> ") + ("(princ 10)" "SWANK> (princ 10) +10 +10 +SWANK> ") + ("(princ 10)(princ 20)" "SWANK> (princ 10)(princ 20) +1020 +20 +SWANK> ") + ("(dotimes (i 10 77) (princ i) (terpri))" + "SWANK> (dotimes (i 10 77) (princ i) (terpri)) +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +77 +SWANK> ")) + (with-current-buffer (slime-output-buffer) + (setf (slime-lisp-package-prompt-string) "SWANK")) + (kill-buffer (slime-output-buffer)) + (with-current-buffer (slime-output-buffer) + (insert input) + (slime-test-expect "Buffer contains input" + (concat "SWANK> " input) + (buffer-string)) + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)))) + +(def-slime-test repl-return + (before after result-contents) + "Test if slime-repl-return sends the correct protion to Lisp even +if point is not at the end of the line." + '(("(+ 1 2)" "" "SWANK> (+ 1 2) +3 +SWANK> ") +("(+ 1 " "2)" "SWANK> (+ 1 2) +3 +SWANK> ") + +("(+ 1\n" "2)" "SWANK> (+ 1 +2) +3 +SWANK> ")) + (with-current-buffer (slime-output-buffer) + (setf (slime-lisp-package-prompt-string) "SWANK")) + (kill-buffer (slime-output-buffer)) + (with-current-buffer (slime-output-buffer) + (insert before) + (save-excursion (insert after)) + (slime-test-expect "Buffer contains input" + (concat "SWANK> " before after) + (buffer-string)) + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)))) + +(def-slime-test repl-read + (prompt input result-contents) + "Test simple commands in the minibuffer." + '(("(read-line)" "foo" "SWANK> (values (read-line)) +foo +\"foo\" +SWANK> ") + ("(read-char)" "1" "SWANK> (values (read-char)) +1 +#\\1 +SWANK> ") + ("(read)" "(+ 2 3 +4)" "SWANK> (values (read)) +\(+ 2 3 +4) +\(+ 2 3 4) +SWANK> ")) + (slime-sync-to-top-level 2) + (with-current-buffer (slime-output-buffer) + (setf (slime-lisp-package-prompt-string) "SWANK")) + (kill-buffer (slime-output-buffer)) + (with-current-buffer (slime-output-buffer) + (insert (format "(values %s)" prompt)) + (call-interactively 'slime-repl-return) + (slime-wait-condition "reading" #'slime-reading-p 5) + (insert input) + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)))) + +(def-slime-test repl-read-lines + (command inputs final-contents) + "Test reading multiple lines from the repl." + '(("(list (read-line) (read-line) (read-line))" + ("a" "b" "c") + "SWANK> (list (read-line) (read-line) (read-line)) +a +b +c +\(\"a\" \"b\" \"c\") +SWANK> ")) + (when (slime-output-buffer) + (kill-buffer (slime-output-buffer))) + (with-current-buffer (slime-output-buffer) + (setf (slime-lisp-package-prompt-string) "SWANK") + (insert command) + (call-interactively 'slime-repl-return) + (dolist (input inputs) + (slime-wait-condition "reading" #'slime-reading-p 5) + (insert input) + (call-interactively 'slime-repl-return)) + (slime-sync-to-top-level 5) + (slime-check "Buffer contains result" + (equal final-contents (buffer-string))))) + +(def-slime-test repl-type-ahead + (command input final-contents) + "Ensure that user input is preserved correctly. +In particular, input inserted while waiting for a result." + '(("(sleep 1)" "foo" "SWANK> (sleep 1) +NIL +SWANK> foo")) + (when (slime-output-buffer) + (kill-buffer (slime-output-buffer))) + (setf (slime-lisp-package-prompt-string) "SWANK") + (with-current-buffer (slime-output-buffer) + (insert command) + (call-interactively 'slime-repl-return) + (insert input) + (slime-sync-to-top-level 5) + (slime-check "Buffer contains result" + (equal final-contents (buffer-string))))) + +(def-slime-test interactive-eval-output + (input result-contents visiblep) + "Test simple commands in the minibuffer." + '(("(+ 1 2)" ";;;; (+ 1 2) ... +SWANK> " nil) + ("(princ 10)" ";;;; (princ 10) ... +10 +SWANK> " t) + ("(princ \"��\")" + ";;;; (princ \"��\") ... +�� +SWANK> " t)) + (when (and (fboundp 'string-to-multibyte) + (with-current-buffer (process-buffer (slime-connection)) + enable-multibyte-characters)) + (setq input (funcall 'string-to-multibyte input)) + (setq result-contents (funcall 'string-to-multibyte result-contents))) + (with-current-buffer (slime-output-buffer) + (setf (slime-lisp-package-prompt-string) "SWANK")) + (kill-buffer (slime-output-buffer)) + (with-current-buffer (slime-output-buffer) + (slime-interactive-eval input) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)) + (slime-test-expect "Buffer visible?" + visiblep + (not (not (get-buffer-window (current-buffer))))))) + +(def-slime-test break + () + "Test if BREAK invokes SLDB." + '(()) + (slime-accept-process-output nil 1) + (slime-check-top-level) + (slime-compile-string (prin1-to-string '(cl:defun cl-user::foo () + (cl:break))) + 0) + (slime-sync-to-top-level 2) + (slime-eval-async '(cl-user::foo)) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window (sldb-get-default-buffer)))) + 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-accept-process-output nil 1) + (slime-sync-to-top-level 5)) + +(def-slime-test interrupt-at-toplevel + () + "Let's see what happens if we send a user interrupt at toplevel." + '(()) + (slime-check-top-level) + (slime-interrupt) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window (sldb-get-default-buffer)))) + 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5)) + +(def-slime-test interrupt-in-blocking-read + () + "Let's see what happens if we interrupt a blocking read operation." + '(()) + (slime-check-top-level) + (when (slime-output-buffer) + (setf (slime-lisp-package-prompt-string) "SWANK") + (kill-buffer (slime-output-buffer))) + (with-current-buffer (slime-output-buffer) + (insert "(read-char)") + (call-interactively 'slime-repl-return)) + (slime-wait-condition "reading" #'slime-reading-p 5) + (slime-interrupt) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window (sldb-get-default-buffer)))) + 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (slime-wait-condition "reading" #'slime-reading-p 5) + (with-current-buffer (slime-output-buffer) + (insert "X") + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + "SWANK> (read-char) +X +#\\X +SWANK> " (buffer-string)))) + +(def-slime-test disconnect + () + "Close the connetion. +Confirm that the subprocess continues gracefully. +Reconnect afterwards." + '(()) + (slime-check-top-level) + (let* ((c (slime-connection)) + (p (slime-inferior-process c))) + (with-current-buffer (process-buffer p) + (erase-buffer)) + (delete-process c) + (assert (equal (process-status c) 'closed) nil "Connection not closed") + (slime-accept-process-output nil 0.1) + (assert (equal (process-status p) 'run) nil "Subprocess not running") + (with-current-buffer (process-buffer p) + (assert (< (buffer-size) 500) nil "Unusual output")) + (slime-inferior-connect p (slime-inferior-lisp-args p)) + (lexical-let ((hook nil)) + (setq hook (lambda () + (remove-hook 'slime-connected-hook hook))) + (add-hook 'slime-connected-hook hook) + (while (member hook slime-connected-hook) + (sit-for 0.5) + (slime-accept-process-output nil 0.1))) + (slime-test-expect "We are connected again" p (slime-inferior-process)))) + + +;;;; Utilities + +;;;;; Misc. + +(defun slime-length= (seq n) + "Test for whether SEQ contains N number of elements. I.e. it's equivalent + to (= (LENGTH SEQ) N), but besides being more concise, it may also be more + efficiently implemented." + (etypecase seq + (list + (let ((list seq)) + (setq list (nthcdr (1- n) list)) + (and list (null (cdr list))))) + (sequence + (= (length seq) n)))) + +(defun slime-length> (seq n) + "Return non-nil if (> (length LIST) N)." + (etypecase seq + (list (nthcdr n seq)) + (seq (> (length seq) n)))) + +(defun slime-split-string (string &optional separators omit-nulls) + "This is like `split-string' in Emacs22, but also works in +Emacs20 and 21." + (let ((splits (split-string string separators))) + (if omit-nulls + (setq splits (remove "" splits)) + ;; SPLIT-STRING in Emacs before 22.x automatically removed nulls + ;; at beginning and end, so we gotta add them here again. + (when (or (slime-emacs-20-p) (slime-emacs-21-p)) + (when (find (elt string 0) separators) + (push "" splits)) + (when (find (elt string (1- (length string))) separators) + (setq splits (append splits (list "")))))) + splits)) + +;;;;; Buffer related + +(defun slime-buffer-narrowed-p (&optional buffer) + "Returns T if BUFFER (or the current buffer respectively) is narrowed." + (with-current-buffer (or buffer (current-buffer)) + (let ((beg (point-min)) + (end (point-max)) + (total (buffer-size))) + (or (/= beg 1) (/= end (1+ total)))))) + + +;;;;; Extracting Lisp forms from the buffer or user + +(defun slime-defun-at-point () + "Return the text of the defun at point." + (apply #'buffer-substring-no-properties + (slime-region-for-defun-at-point))) + +(defun slime-region-for-defun-at-point () + "Return the start and end position of the toplevel form at point." + (save-excursion + (save-match-data + (end-of-defun) + (let ((end (point))) + (beginning-of-sexp) + (list (point) end))))) + +(defun slime-beginning-of-symbol () + "Move point to the beginning of the current symbol." + (when (slime-point-moves-p + (while (slime-point-moves-p + (skip-syntax-backward "w_") + (when (eq (char-before) ?|) + (backward-char))))) + (when (eq (char-before) ?#) ; special case for things like "#<foo" + (forward-char)))) + +(defun slime-end-of-symbol () + "Move point to the end of the current symbol." + (while (slime-point-moves-p + (skip-syntax-forward "w_") + ;; | has the syntax as ", so we need to + ;; treat it manually rather than via syntax. + (when (looking-at "|") + (forward-char))))) + +(put 'slime-symbol 'end-op 'slime-end-of-symbol) +(put 'slime-symbol 'beginning-op 'slime-beginning-of-symbol) + +(defun slime-symbol-start-pos () + "Return the starting position of the symbol under point. +The result is unspecified if there isn't a symbol under the point." + (save-excursion (slime-beginning-of-symbol) (point))) + +(defun slime-symbol-end-pos () + (save-excursion (slime-end-of-symbol) (point))) + +(defun slime-symbol-name-at-point () + "Return the name of the symbol at point, otherwise nil." + (save-restriction + ;; Don't be tricked into grabbing the REPL prompt. + (when (and (eq major-mode 'slime-repl-mode) + (>= (point) slime-repl-input-start-mark)) + (narrow-to-region slime-repl-input-start-mark (point-max))) + (save-excursion + (let ((string (thing-at-point 'slime-symbol))) + (and string + ;; In Emacs20 (thing-at-point 'symbol) returns "" instead + ;; of nil when called from an empty (or + ;; narrowed-to-empty) buffer. + (not (equal string "")) + (substring-no-properties string)))))) + +(defun slime-symbol-at-point () + "Return the symbol at point, otherwise nil." + (let ((name (slime-symbol-name-at-point))) + (and name (intern name)))) + +(defun slime-sexp-at-point () + "Return the sexp at point as a string, otherwise nil." + (let ((string (thing-at-point 'sexp))) + (if string (substring-no-properties string) nil))) + +(defun slime-sexp-at-point-or-error () + "Return the sexp at point as a string, othwise signal an error." + (or (slime-sexp-at-point) + (error "No expression at point."))) + +;;;; Portability library + +(when (featurep 'xemacs) + (require 'overlay)) + +(defmacro slime-defun-if-undefined (name &rest rest) + ;; We can't decide at compile time whether NAME is properly + ;; bound. So we delay the decision to runtime to ensure some + ;; definition + `(unless (fboundp ',name) + (defun ,name ,@rest))) + +(put 'slime-defun-if-undefined 'lisp-indent-function 2) + +(defvar slime-accept-process-output-supports-floats + (ignore-errors (accept-process-output nil 0.0) t)) + +(defun slime-accept-process-output (&optional process timeout) + "Like `accept-process-output' but the TIMEOUT argument can be a float." + (cond (slime-accept-process-output-supports-floats + (accept-process-output process timeout)) + (t + (accept-process-output process + (if timeout (truncate timeout)) + ;; Emacs 21 uses microsecs; Emacs 22 millisecs + (if timeout (truncate (* timeout 1000000))))))) + +(slime-defun-if-undefined next-single-char-property-change + (position prop &optional object limit) + (let ((limit (typecase limit + (null nil) + (marker (marker-position limit)) + (t limit)))) + (if (stringp object) + (or (next-single-property-change position prop object limit) + limit + (length object)) + (with-current-buffer (or object (current-buffer)) + (let ((initial-value (get-char-property position prop object)) + (limit (or limit (point-max)))) + (loop for pos = position then (next-char-property-change pos limit) + if (>= pos limit) return limit + if (not (eq initial-value + (get-char-property pos prop object))) + return pos)))))) + +(slime-defun-if-undefined previous-single-char-property-change + (position prop &optional object limit) + (let ((limit (typecase limit + (null nil) + (marker (marker-position limit)) + (t limit)))) + (if (stringp object) + (or (previous-single-property-change position prop object limit) + limit + (length object)) + (with-current-buffer (or object (current-buffer)) + (let ((limit (or limit (point-min)))) + (if (<= position limit) + limit + (let ((initial-value (get-char-property (1- position) + prop object))) + (loop for pos = position then + (previous-char-property-change pos limit) + if (<= pos limit) return limit + if (not (eq initial-value + (get-char-property (1- pos) prop object))) + return pos)))))))) + +(slime-defun-if-undefined next-char-property-change (position &optional limit) + (let ((tmp (next-overlay-change position))) + (when tmp + (setq tmp (min tmp limit))) + (next-property-change position nil tmp))) + +(slime-defun-if-undefined previous-char-property-change + (position &optional limit) + (let ((tmp (previous-overlay-change position))) + (when tmp + (setq tmp (max tmp limit))) + (previous-property-change position nil tmp))) + +(slime-defun-if-undefined substring-no-properties (string &optional start end) + (let* ((start (or start 0)) + (end (or end (length string))) + (string (substring string start end))) + (set-text-properties 0 (- end start) nil string) + string)) + +(slime-defun-if-undefined match-string-no-properties (num &optional string) + (if (match-beginning num) + (if string + (substring-no-properties string (match-beginning num) + (match-end num)) + (buffer-substring-no-properties (match-beginning num) + (match-end num))))) + +(slime-defun-if-undefined set-window-text-height (window height) + (let ((delta (- height (window-text-height window)))) + (unless (zerop delta) + (let ((window-min-height 1)) + (if (and window (not (eq window (selected-window)))) + (save-selected-window + (select-window window) + (enlarge-window delta)) + (enlarge-window delta)))))) + +(slime-defun-if-undefined window-text-height (&optional window) + (1- (window-height window))) + +(slime-defun-if-undefined subst-char-in-string (fromchar tochar string + &optional inplace) + "Replace FROMCHAR with TOCHAR in STRING each time it occurs. +Unless optional argument INPLACE is non-nil, return a new string." + (let ((i (length string)) + (newstr (if inplace string (copy-sequence string)))) + (while (> i 0) + (setq i (1- i)) + (if (eq (aref newstr i) fromchar) + (aset newstr i tochar))) + newstr)) + +(slime-defun-if-undefined count-screen-lines + (&optional beg end count-final-newline window) + (unless beg + (setq beg (point-min))) + (unless end + (setq end (point-max))) + (if (= beg end) + 0 + (save-excursion + (save-restriction + (widen) + (narrow-to-region (min beg end) + (if (and (not count-final-newline) + (= ?\n (char-before (max beg end)))) + (1- (max beg end)) + (max beg end))) + (goto-char (point-min)) + ;; XXX make this xemacs compatible + (1+ (vertical-motion (buffer-size) window)))))) + +(slime-defun-if-undefined seconds-to-time (seconds) + "Convert SECONDS (a floating point number) to a time value." + (list (floor seconds 65536) + (floor (mod seconds 65536)) + (floor (* (- seconds (ffloor seconds)) 1000000)))) + +(slime-defun-if-undefined time-less-p (t1 t2) + "Say whether time value T1 is less than time value T2." + (or (< (car t1) (car t2)) + (and (= (car t1) (car t2)) + (< (nth 1 t1) (nth 1 t2))))) + +(slime-defun-if-undefined time-add (t1 t2) + "Add two time values. One should represent a time difference." + (let ((high (car t1)) + (low (if (consp (cdr t1)) (nth 1 t1) (cdr t1))) + (micro (if (numberp (car-safe (cdr-safe (cdr t1)))) + (nth 2 t1) + 0)) + (high2 (car t2)) + (low2 (if (consp (cdr t2)) (nth 1 t2) (cdr t2))) + (micro2 (if (numberp (car-safe (cdr-safe (cdr t2)))) + (nth 2 t2) + 0))) + ;; Add + (setq micro (+ micro micro2)) + (setq low (+ low low2)) + (setq high (+ high high2)) + + ;; Normalize + ;; `/' rounds towards zero while `mod' returns a positive number, + ;; so we can't rely on (= a (+ (* 100 (/ a 100)) (mod a 100))). + (setq low (+ low (/ micro 1000000) (if (< micro 0) -1 0))) + (setq micro (mod micro 1000000)) + (setq high (+ high (/ low 65536) (if (< low 0) -1 0))) + (setq low (logand low 65535)) + + (list high low micro))) + +(slime-defun-if-undefined line-beginning-position (&optional n) + (save-excursion + (beginning-of-line n) + (point))) + +(slime-defun-if-undefined line-end-position (&optional n) + (save-excursion + (end-of-line n) + (point))) + +(slime-defun-if-undefined check-parens () + "Verify that parentheses in the current buffer are balanced. +If they are not, position point at the first syntax error found." + (interactive) + (let ((saved-point (point)) + (state (parse-partial-sexp (point-min) (point-max) -1))) + (destructuring-bind (depth innermost-start last-terminated-start + in-string in-comment after-quote + minimum-depth comment-style + comment-or-string-start &rest _) state + (cond ((and (zerop depth) + (not in-string) + (or (not in-comment) + (and (eq comment-style nil) + (eobp))) + (not after-quote)) + (goto-char saved-point) + (message "All parentheses appear to be balanced.")) + ((plusp depth) + (goto-char innermost-start) + (error "Missing )")) + ((minusp depth) + (error "Extra )")) + (in-string + (goto-char comment-or-string-start) + (error "String not terminated")) + (in-comment + (goto-char comment-or-string-start) + (error "Comment not terminated")) + (after-quote + (error "After quote")) + (t (error "Shouldn't happen: parsing state: %S" state)))))) + +(slime-defun-if-undefined read-directory-name (prompt + &optional dir default-dirname + mustmatch initial) + (unless dir + (setq dir default-directory)) + (unless default-dirname + (setq default-dirname + (if initial (concat dir initial) default-directory))) + (let ((file (read-file-name prompt dir default-dirname mustmatch initial))) + (setq file (file-name-as-directory (expand-file-name file))) + (cond ((file-directory-p file) + file) + (t + (error "Not a directory: %s" file))))) + +(slime-defun-if-undefined check-coding-system (coding-system) + (or (eq coding-system 'binary) + (error "No such coding system: %S" coding-system))) + +(slime-defun-if-undefined process-coding-system (process) + '(binary . binary)) + +(slime-defun-if-undefined set-process-coding-system + (process &optional decoding encoding)) + +(unless (boundp 'temporary-file-directory) + (defvar temporary-file-directory + (file-name-as-directory + (cond ((memq system-type '(ms-dos windows-nt)) + (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp")) + ((memq system-type '(vax-vms axp-vms)) + (or (getenv "TMPDIR") (getenv "TMP") + (getenv "TEMP") "SYS$SCRATCH:")) + (t + (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp")))) + "The directory for writing temporary files.")) + +(unless (fboundp 'with-temp-message) + (defmacro with-temp-message (message &rest body) + (let ((current-message (make-symbol "current-message")) + (temp-message (make-symbol "with-temp-message"))) + `(let ((,temp-message ,message) + (,current-message)) + (unwind-protect + (progn + (when ,temp-message + (setq ,current-message (current-message)) + (message "%s" ,temp-message)) + ,@body) + (and ,temp-message ,current-message + (message "%s" ,current-message))))))) + +(defun slime-emacs-20-p () + (and (not (featurep 'xemacs)) + (= emacs-major-version 20))) + +(defun slime-emacs-21-p () + (and (not (featurep 'xemacs)) + (= emacs-major-version 21))) + +(when (featurep 'xemacs) + (add-hook 'sldb-hook 'sldb-xemacs-emulate-point-entered-hook)) + +(defun sldb-xemacs-emulate-point-entered-hook () + (add-hook (make-local-variable 'post-command-hook) + 'sldb-xemacs-post-command-hook)) + +(defun sldb-xemacs-post-command-hook () + (when (get-text-property (point) 'point-entered) + (funcall (get-text-property (point) 'point-entered)))) + +(slime-defun-if-undefined with-selected-window (window &rest body) + `(save-selected-window + (select-window ,window) + ,@body)) + +;;; Stuff only available in XEmacs +(slime-defun-if-undefined add-local-hook (hook function &optional append) + (make-local-hook hook) + (add-hook hook function append t)) + +(slime-defun-if-undefined remove-local-hook (hook function) + (if (local-variable-p hook (current-buffer)) + (remove-hook hook function t))) + +;;;; Some "nice" backward compatiblity bindings for lusers. + +(defvar slime-obsolete-commands + '(("\C-c\M-i" (slime repl) slime-fuzzy-complete-symbol) + ;; Don't shadow bindings in lisp-mode-map + ;;("\M-\C-a" (slime) slime-beginning-of-defun) + ;;("\M-\C-e" (slime) slime-end-of-defun) + ("\C-c\M-q" (slime) slime-reindent-defun) + ("\C-c\C-s" (slime) slime-complete-form) + ;; (nil nil slime-close-all-parens-in-sexp) + )) + +(defun slime-bind-obsolete-commands () + (loop for (key maps command) in slime-obsolete-commands do + (dolist (m maps) (slime-bind-obsolete-command m key command)))) + +(defun slime-bind-obsolete-command (map key command) + (let ((map (ecase map + (slime slime-mode-map) + (repl slime-repl-mode-map)))) + (unless (lookup-key map key) + (define-key map key `(lambda (&rest _) + (interactive) + (slime-upgrade-notice ',command)))))) + +(slime-bind-obsolete-commands) + +(defun slime-upgrade-notice (command) + (slime-timebomb (format "The command `%s' has been moved to contrib. +Please consult the README file in the contrib directory for details. + +To fetch the contrib directoy use: cvs update -d" + command) + 15)) + +;;;;; ... with gratuitous bloat + +(defun slime-timebomb (message timeout) + (with-current-buffer (generate-new-buffer "*warning*") + (insert message "\n\n") + (slime-timebomb-progress (point-marker) timeout) + (goto-char (point-min)) + (pop-to-buffer (current-buffer)))) + +(defun slime-timebomb-progress (mark timeout) + (let ((buffer (marker-buffer mark))) + (cond ((not (buffer-live-p buffer))) + ((zerop timeout) (kill-buffer buffer)) + (t (with-current-buffer buffer + (save-excursion + (delete-region mark (point-max)) + (goto-char mark) + (slime-timebomb-message timeout)) + (run-with-timer 1 nil + 'slime-timebomb-progress mark (1- timeout))))))) + +(defun slime-timebomb-message (timeout) + (slime-insert-propertized + (list 'face (if (zerop (mod timeout 2)) 'highlight 'default)) + (format "This message will destroy itself in %d seconds." timeout))) + + +;;;; Finishing up + +(require 'bytecomp) +(let ((byte-compile-warnings '())) + (mapc #'byte-compile + '(slime-alistify + slime-log-event + slime-events-buffer + slime-write-string + slime-output-buffer + slime-connection-output-buffer + slime-output-filter + slime-repl-show-maximum-output + slime-process-available-input + slime-dispatch-event + slime-net-filter + slime-net-have-input-p + slime-net-decode-length + slime-net-read + slime-print-apropos + slime-show-note-counts + slime-insert-propertized + slime-tree-insert))) + +(provide 'slime) +(run-hooks 'slime-load-hook) + +;; Local Variables: +;; outline-regexp: ";;;;+" +;; indent-tabs-mode: nil +;; coding: latin-1-unix! +;; unibyte: t +;; compile-command: "emacs -batch -L . -eval '(byte-compile-file \"slime.el\")' ; rm -v slime.elc" +;; End: +;;; slime.el ends here Added: branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,541 @@ +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*- +;;; +;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME. +;;; +;;; Adapted from swank-acl.lisp, Andras Simon, 2004 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package :swank-backend) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :collect) ;just so that it doesn't spoil the flying letters + (require :pprint)) + +(defun sys::break (&optional (format-control "BREAK called") + &rest format-arguments) + (let ((*saved-backtrace* (backtrace-as-list-ignoring-swank-calls))) + (with-simple-restart (continue "Return from BREAK.") + (invoke-debugger + (sys::%make-condition 'simple-condition + (list :format-control format-control + :format-arguments format-arguments)))) + nil)) + +(defimplementation make-fn-streams (input-fn output-fn) + (let* ((output (ext:make-slime-output-stream output-fn)) + (input (ext:make-slime-input-stream input-fn output))) + (values input output))) + +(defimplementation call-with-compilation-hooks (function) + (funcall function)) + +;;; swank-mop + +;;dummies and definition + +(defclass standard-slot-definition ()()) + +;(defun class-finalized-p (class) t) + +(defun slot-definition-documentation (slot) #+nil (documentation slot 't)) +(defun slot-definition-type (slot) t) +(defun class-prototype (class)) +(defun generic-function-declarations (gf)) +(defun specializer-direct-methods (spec) (mop::class-direct-methods spec)) + +(defun slot-definition-name (slot) + (mop::%slot-definition-name slot)) + +(defun class-slots (class) + (mop::%class-slots class)) + +(defun method-generic-function (method) + (mop::%method-generic-function method)) + +(defun method-function (method) + (mop::%method-function method)) + +(defun slot-boundp-using-class (class object slotdef) + (system::slot-boundp object (slot-definition-name slotdef))) + +(defun slot-value-using-class (class object slotdef) + (system::slot-value object (slot-definition-name slotdef))) + +(import-to-swank-mop + '( ;; classes + cl:standard-generic-function + standard-slot-definition ;;dummy + cl:method + cl:standard-class + ;; standard-class readers + mop::class-default-initargs + mop::class-direct-default-initargs + mop::class-direct-slots + mop::class-direct-subclasses + mop::class-direct-superclasses + mop::eql-specializer + mop::class-finalized-p + cl:class-name + mop::class-precedence-list + class-prototype ;;dummy + class-slots + specializer-direct-methods + ;; eql-specializer accessors + mop::eql-specializer-object + ;; generic function readers + mop::generic-function-argument-precedence-order + generic-function-declarations ;;dummy + mop::generic-function-lambda-list + mop::generic-function-methods + mop::generic-function-method-class + mop::generic-function-method-combination + mop::generic-function-name + ;; method readers + method-generic-function + method-function + mop::method-lambda-list + mop::method-specializers + mop::method-qualifiers + ;; slot readers + mop::slot-definition-allocation + slot-definition-documentation ;;dummy + mop::slot-definition-initargs + mop::slot-definition-initform + mop::slot-definition-initfunction + slot-definition-name + slot-definition-type ;;dummy + mop::slot-definition-readers + mop::slot-definition-writers + slot-boundp-using-class + slot-value-using-class + )) + +;;;; TCP Server + + +(defimplementation preferred-communication-style () + :spawn) + + + +(defimplementation create-socket (host port) + (ext:make-server-socket port)) + + +(defimplementation local-port (socket) + (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket)) + + +(defimplementation close-socket (socket) + (ext:server-socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout external-format)) + (ext:get-socket-stream (ext:socket-accept socket))) + +;;;; Unix signals + +(defimplementation call-without-interrupts (fn) + (funcall fn)) + +;;there are too many to count +(defimplementation getpid () + 0) + +(defimplementation lisp-implementation-type-name () + "armedbear") + +(defimplementation set-default-directory (directory) + (let ((dir (sys::probe-directory directory))) + (when dir (setf *default-pathname-defaults* dir)) + (namestring dir))) + + +;;;; Misc + +(defimplementation arglist (fun) + (cond ((symbolp fun) + (multiple-value-bind (arglist present) (sys::arglist fun) + (if present arglist :not-available))) + (t :not-available))) + +(defimplementation function-name (function) + (nth-value 2 (function-lambda-expression function))) + +(defimplementation macroexpand-all (form) + (macroexpand form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + + +;;;; Debugger + +(defvar *sldb-topframe*) + +(defun backtrace-as-list-ignoring-swank-calls () + (let ((list (ext:backtrace-as-list))) + (subseq list (1+ (or (position (intern "SWANK-DEBUGGER-HOOK" 'swank) list :key 'car) -1))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let ((*sldb-topframe* (car (backtrace-as-list-ignoring-swank-calls)) #+nil (excl::int-newest-frame))) + (funcall debugger-loop-fn))) + +(defun nth-frame (index) + (nth index (backtrace-as-list-ignoring-swank-calls))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (subseq (backtrace-as-list-ignoring-swank-calls) start end))) + +(defimplementation print-frame (frame stream) + (write-string (string-trim '(#\space #\newline) + (prin1-to-string frame)) + stream)) + +(defimplementation frame-locals (index) + `(,(list :name "??" :id 0 :value "??"))) + + +(defimplementation frame-catch-tags (index) + (declare (ignore index)) + nil) + +#+nil +(defimplementation disassemble-frame (index) + (disassemble (debugger:frame-function (nth-frame index)))) + +(defimplementation frame-source-location-for-emacs (index) + (list :error (format nil "Cannot find source for frame: ~A" + (nth-frame index)))) + +#+nil +(defimplementation eval-in-frame (form frame-number) + (debugger:eval-form-in-context + form + (debugger:environment-of-frame (nth-frame frame-number)))) + +#+nil +(defimplementation return-from-frame (frame-number form) + (let ((frame (nth-frame frame-number))) + (multiple-value-call #'debugger:frame-return + frame (debugger:eval-form-in-context + form + (debugger:environment-of-frame frame))))) + +;;; XXX doesn't work for frames with arguments +#+nil +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (debugger:frame-retry frame (debugger:frame-function frame)))) + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(in-package :swank-backend) + +(defun handle-compiler-warning (condition) + (let ((loc nil));(getf (slot-value condition 'excl::plist) :loc))) + (unless (member condition *abcl-signaled-conditions*) ; filter condition signaled more than once. + (push condition *abcl-signaled-conditions*) + (signal (make-condition + 'compiler-condition + :original-condition condition + :severity :warning + :message (format nil "~A" condition) + :location (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :position *buffer-start-position*))) + (loc + (destructuring-bind (file . pos) loc + (make-location + (list :file (namestring (truename file))) + (list :position (1+ pos))))) + (t + (make-location + (list :file *compile-filename*) + (list :position 1))))))))) + +(defvar *abcl-signaled-conditions*) + +(defimplementation swank-compile-file (filename load-p external-format) + (declare (ignore external-format)) + (let ((jvm::*resignal-compiler-warnings* t) + (*abcl-signaled-conditions* nil)) + (handler-bind ((warning #'handle-compiler-warning)) + (let ((*buffer-name* nil) + (*compile-filename* filename)) + (multiple-value-bind (fn warn fail) (compile-file filename) + (when (and load-p (not fail)) + (load fn))))))) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (let ((jvm::*resignal-compiler-warnings* t) + (*abcl-signaled-conditions* nil)) + (handler-bind ((warning #'handle-compiler-warning)) + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))))))) + +#| +;;;; Definition Finding + +(defun find-fspec-location (fspec type) + (let ((file (excl::fspec-pathname fspec type))) + (etypecase file + (pathname + (let ((start (scm:find-definition-in-file fspec type file))) + (make-location (list :file (namestring (truename file))) + (if start + (list :position (1+ start)) + (list :function-name (string fspec)))))) + ((member :top-level) + (list :error (format nil "Defined at toplevel: ~A" fspec))) + (null + (list :error (format nil "Unkown source location for ~A" fspec)))))) + +(defun fspec-definition-locations (fspec) + (let ((defs (excl::find-multiple-definitions fspec))) + (loop for (fspec type) in defs + collect (list fspec (find-fspec-location fspec type))))) + +(defimplementation find-definitions (symbol) + (fspec-definition-locations symbol)) + +|# + +(defun source-location (symbol) + (when (pathnamep (ext:source-pathname symbol)) + `(((,symbol) + (:location + (:file ,(namestring (ext:source-pathname symbol))) + (:position ,(or (ext:source-file-position symbol) 0) t) + (:snippet nil)))))) + + +(defimplementation find-definitions (symbol) + (source-location symbol)) + +#| +Uncomment this if you have patched xref.lisp, as in +http://article.gmane.org/gmane.lisp.slime.devel/2425 +Also, make sure that xref.lisp is loaded by modifying the armedbear +part of *sysdep-pathnames* in swank.loader.lisp. + +;;;; XREF +(setq pxref:*handle-package-forms* '(cl:in-package)) + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls pxref:list-callers) +(defxref who-references pxref:list-readers) +(defxref who-binds pxref:list-setters) +(defxref who-sets pxref:list-setters) +(defxref list-callers pxref:list-callers) +(defxref list-callees pxref:list-callees) + +(defun xref-results (symbols) + (let ((xrefs '())) + (dolist (symbol symbols) + (push (list symbol (cadar (source-location symbol))) xrefs)) + xrefs)) +|# + +;;;; Inspecting + +(defclass abcl-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'abcl-inspector)) + +(defmethod inspect-for-emacs ((slot mop::slot-definition) + (inspector backend-inspector)) + (declare (ignore inspector)) + (values "A slot." + `("Name: " (:value ,(mop::%slot-definition-name slot)) + (:newline) + "Documentation:" (:newline) + ,@(when (slot-definition-documentation slot) + `((:value ,(slot-definition-documentation slot)) (:newline))) + "Initialization:" (:newline) + " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline) + " Form: " ,(if (mop::%slot-definition-initfunction slot) + `(:value ,(mop::%slot-definition-initform slot)) + "#<unspecified>") (:newline) + " Function: " (:value ,(mop::%slot-definition-initfunction slot)) + (:newline)))) + +(defmethod inspect-for-emacs ((f function) (inspector backend-inspector)) + (declare (ignore inspector)) + (values "A function." + `(,@(when (function-name f) + `("Name: " + ,(princ-to-string (function-name f)) (:newline))) + ,@(multiple-value-bind (args present) + (sys::arglist f) + (when present `("Argument list: " ,(princ-to-string args) (:newline)))) + (:newline) + #+nil,@(when (documentation f t) + `("Documentation:" (:newline) ,(documentation f t) (:newline))) + ,@(when (function-lambda-expression f) + `("Lambda expression:" + (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline)))))) + +#| + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (let* ((class (class-of o)) + (slots (mop::class-slots class))) + (values (format nil "~A~% is a ~A" o class) + (mapcar (lambda (slot) + (let ((name (mop::slot-definition-name slot))) + (cons (princ-to-string name) + (slot-value o name)))) + slots)))) +|# + +;;;; Multithreading + +(defimplementation startup-multiprocessing () + #+nil(mp:start-scheduler)) + +(defimplementation spawn (fn &key name) + (ext:make-thread (lambda () (funcall fn)) :name name)) + +(defvar *thread-props-lock* (ext:make-thread-lock)) + +(defvar *thread-props* (make-hash-table) ; should be a weak table + "A hashtable mapping threads to a plist.") + +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (ext:with-thread-lock (*thread-props-lock*) + (or (getf (gethash thread *thread-props*) 'id) + (setf (getf (gethash thread *thread-props*) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (thread) + (getf (gethash thread *thread-props*) 'id)))) + +(defimplementation thread-name (thread) + (ext:thread-name thread)) + +(defimplementation thread-status (thread) + (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread))) + +(defimplementation make-lock (&key name) + (ext:make-thread-lock)) + +(defimplementation call-with-lock-held (lock function) + (ext:with-thread-lock (lock) (funcall function))) + +(defimplementation current-thread () + (ext:current-thread)) + +(defimplementation all-threads () + (copy-list (ext:mapcar-threads #'identity))) + +(defimplementation interrupt-thread (thread fn) + (ext:interrupt-thread thread fn)) + +(defimplementation kill-thread (thread) + (ext:destroy-thread thread)) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (ext:with-thread-lock (*thread-props-lock*) + (or (getf (gethash thread *thread-props*) 'mailbox) + (setf (getf (gethash thread *thread-props*) 'mailbox) + (ext:make-mailbox))))) + +(defimplementation send (thread object) + (ext:mailbox-send (mailbox thread) object)) + +(defimplementation receive () + (ext:mailbox-read (mailbox (ext:current-thread)))) + +;;; Auto-flush streams + +;; XXX race conditions +(defvar *auto-flush-streams* '()) + +(defvar *auto-flush-thread* nil) + +(defimplementation make-stream-interactive (stream) + (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*)) + (unless *auto-flush-thread* + (setq *auto-flush-thread* + (ext:make-thread #'flush-streams + :name "auto-flush-thread")))) + +(defun flush-streams () + (loop + (setq *auto-flush-streams* + (remove-if (lambda (x) + (not (and (open-stream-p x) + (output-stream-p x)))) + *auto-flush-streams*)) + (mapc #'finish-output *auto-flush-streams*) + (sleep 0.15))) + +(defimplementation quit-lisp () + (ext:exit)) + +;; WORKAROUND: call/initialize accessors at load time +(let ((c (make-condition 'compiler-condition + :original-condition nil + :severity ':note :message "" :location nil)) + (slots `(severity message short-message references location))) + (dolist (slot slots) + (funcall slot c))) Added: branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,774 @@ +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*- +;;; +;;; swank-allegro.lisp --- Allegro CL specific code for SLIME. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package :swank-backend) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sock) + (require :process)) + +(import-from :excl *gray-stream-symbols* :swank-backend) + +;;; swank-mop + +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port) + (socket:make-socket :connect :passive :local-port port + :local-host host :reuse-address t)) + +(defimplementation local-port (socket) + (socket:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format buffering + timeout) + (declare (ignore buffering timeout)) + (let ((s (socket:accept-connection socket :wait t))) + (when external-format + (setf (stream-external-format s) external-format)) + s)) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix") + (:us-ascii "us-ascii" "us-ascii-unix") + (:emacs-mule "emacs-mule" "emacs-mule-unix"))) + +(defimplementation find-external-format (coding-system) + (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + (and e (excl:crlf-base-ef + (excl:find-external-format (car e) + :try-variant t))))) + +(defimplementation format-sldb-condition (c) + (princ-to-string c)) + +(defimplementation call-with-syntax-hooks (fn) + (funcall fn)) + +;;;; Unix signals + +(defimplementation call-without-interrupts (fn) + (excl:without-interrupts (funcall fn))) + +(defimplementation getpid () + (excl::getpid)) + +(defimplementation lisp-implementation-type-name () + "allegro") + +(defimplementation set-default-directory (directory) + (let* ((dir (namestring (truename (merge-pathnames directory))))) + (setf *default-pathname-defaults* (pathname (excl:chdir dir))) + dir)) + +(defimplementation default-directory () + (namestring (excl:current-directory))) + +;;;; Misc + +(defimplementation arglist (symbol) + (handler-case (excl:arglist symbol) + (simple-error () :not-available))) + +(defimplementation macroexpand-all (form) + (excl::walk form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation make-stream-interactive (stream) + (setf (interactive-stream-p stream) t)) + +;;;; Debugger + +(defvar *sldb-topframe*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let ((*sldb-topframe* (find-topframe)) + (excl::*break-hook* nil)) + (funcall debugger-loop-fn))) + +(defimplementation sldb-break-at-start (fname) + ;; :print-before is kind of mis-used but we just want to stuff our break form + ;; somewhere. This does not work for setf, :before and :after methods, which + ;; need special syntax in the trace call, see ACL's doc/debugging.htm chapter 10. + (eval `(trace (,fname + :print-before + ((break "Function start breakpoint of ~A" ',fname))))) + `(:ok ,(format nil "Set breakpoint at start of ~S" fname))) + +(defun find-topframe () + (let ((skip-frames 3)) + (do ((f (excl::int-newest-frame) (next-frame f)) + (i 0 (1+ i))) + ((= i skip-frames) f)))) + +(defun next-frame (frame) + (let ((next (excl::int-next-older-frame frame))) + (cond ((not next) nil) + ((debugger:frame-visible-p next) next) + (t (next-frame next))))) + +(defun nth-frame (index) + (do ((frame *sldb-topframe* (next-frame frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (next-frame f) + for i from start below end + while f + collect f))) + +(defimplementation print-frame (frame stream) + (debugger:output-frame stream frame :moderate)) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + (loop for i from 0 below (debugger:frame-number-vars frame) + collect (list :name (debugger:frame-var-name frame i) + :id 0 + :value (debugger:frame-var-value frame i))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (debugger:frame-var-value frame var))) + +(defimplementation frame-catch-tags (index) + (declare (ignore index)) + nil) + +(defimplementation disassemble-frame (index) + (disassemble (debugger:frame-function (nth-frame index)))) + +(defimplementation frame-source-location-for-emacs (index) + (let* ((frame (nth-frame index)) + (expr (debugger:frame-expression frame)) + (fspec (first expr))) + (second (first (fspec-definition-locations fspec))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + ;; let-bind lexical variables + (let ((vars (loop for i below (debugger:frame-number-vars frame) + for name = (debugger:frame-var-name frame i) + if (symbolp name) + collect `(,name ',(debugger:frame-var-value frame i))))) + (debugger:eval-form-in-context + `(let* ,vars ,form) + (debugger:environment-of-frame frame))))) + +(defimplementation return-from-frame (frame-number form) + (let ((frame (nth-frame frame-number))) + (multiple-value-call #'debugger:frame-return + frame (debugger:eval-form-in-context + form + (debugger:environment-of-frame frame))))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (cond ((debugger:frame-retryable-p frame) + (apply #'debugger:frame-retry frame (debugger:frame-function frame) + (cdr (debugger:frame-expression frame)))) + (t "Frame is not retryable")))) + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +(defun compiler-note-p (object) + (member (type-of object) '(excl::compiler-note compiler::compiler-note))) + +(defun compiler-undefined-functions-called-warning-p (object) + (typep object 'excl:compiler-undefined-functions-called-warning)) + +(deftype compiler-note () + `(satisfies compiler-note-p)) + +(defun signal-compiler-condition (&rest args) + (signal (apply #'make-condition 'compiler-condition args))) + +(defun handle-compiler-warning (condition) + (declare (optimize (debug 3) (speed 0) (space 0))) + (cond ((and (not *buffer-name*) + (compiler-undefined-functions-called-warning-p condition)) + (handle-undefined-functions-warning condition)) + (t + (signal-compiler-condition + :original-condition condition + :severity (etypecase condition + (warning :warning) + (compiler-note :note)) + :message (format nil "~A" condition) + :location (location-for-warning condition))))) + +(defun location-for-warning (condition) + (let ((loc (getf (slot-value condition 'excl::plist) :loc))) + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :position *buffer-start-position*))) + (loc + (destructuring-bind (file . pos) loc + (make-location + (list :file (namestring (truename file))) + (list :position (1+ pos))))) + (t + (list :error "No error location available."))))) + +(defun handle-undefined-functions-warning (condition) + (let ((fargs (slot-value condition 'excl::format-arguments))) + (loop for (fname . pos-file) in (car fargs) do + (loop for (pos file) in pos-file do + (signal-compiler-condition + :original-condition condition + :severity :warning + :message (format nil "Undefined function referenced: ~S" + fname) + :location (make-location (list :file file) + (list :position (1+ pos)))))))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-compiler-warning) + ;;(compiler-note #'handle-compiler-warning) + ) + (funcall function))) + +(defimplementation swank-compile-file (filename load-p external-format) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* filename)) + (compile-file *compile-filename* :load-after-compile load-p + :external-format external-format)))) + +(defun call-with-temp-file (fn) + (let ((tmpname (system:make-temp-file-name))) + (unwind-protect + (with-open-file (file tmpname :direction :output :if-exists :error) + (funcall fn file tmpname)) + (delete-file tmpname)))) + +(defun compile-from-temp-file (string) + (call-with-temp-file + (lambda (stream filename) + (write-string string stream) + (finish-output stream) + (let ((binary-filename + (excl:without-redefinition-warnings + ;; Suppress Allegro's redefinition warnings; they are + ;; pointless when we are compiling via a temporary + ;; file. + (compile-file filename :load-after-compile t)))) + (when binary-filename + (delete-file binary-filename)))))) + +(defimplementation swank-compile-string (string &key buffer position directory) + ;; We store the source buffer in excl::*source-pathname* as a string + ;; of the form <buffername>;<start-offset>. Quite ugly encoding, but + ;; the fasl file is corrupted if we use some other datatype. + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string) + (*default-pathname-defaults* + (if directory (merge-pathnames (pathname directory)) + *default-pathname-defaults*))) + (compile-from-temp-file + (format nil "~S ~S~%~A" + `(in-package ,(package-name *package*)) + `(eval-when (:compile-toplevel :load-toplevel) + (setq excl::*source-pathname* + ',(format nil "~A;~D" buffer position))) + string))))) + +;;;; Definition Finding + +(defun fspec-primary-name (fspec) + (etypecase fspec + (symbol fspec) + (list (fspec-primary-name (second fspec))))) + +;; If Emacs uses DOS-style eol conventions, \n\r are considered as a +;; single character, but file-position counts them as two. Here we do +;; our own conversion. +(defun count-cr (file pos) + (let* ((bufsize 256) + (type '(unsigned-byte 8)) + (buf (make-array bufsize :element-type type)) + (cr-count 0)) + (with-open-file (stream file :direction :input :element-type type) + (loop for bytes-read = (read-sequence buf stream) do + (incf cr-count (count (char-code #\return) buf + :end (min pos bytes-read))) + (decf pos bytes-read) + (when (<= pos 0) + (return cr-count)))))) + +(defun find-definition-in-file (fspec type file top-level) + (let* ((part + (or (scm::find-definition-in-definition-group + fspec type (scm:section-file :file file) + :top-level top-level) + (scm::find-definition-in-definition-group + (fspec-primary-name fspec) + type (scm:section-file :file file) + :top-level top-level))) + (start (and part + (scm::source-part-start part))) + (pos (if start + (list :position (1+ (- start (count-cr file start)))) + (list :function-name (string (fspec-primary-name fspec)))))) + (make-location (list :file (namestring (truename file))) + pos))) + +(defun find-definition-in-buffer (filename) + (let ((pos (position #\; filename :from-end t))) + (make-location + (list :buffer (subseq filename 0 pos)) + (list :position (parse-integer (subseq filename (1+ pos))))))) + +(defun find-fspec-location (fspec type file top-level) + (etypecase file + (pathname + (find-definition-in-file fspec type file top-level)) + ((member :top-level) + (list :error (format nil "Defined at toplevel: ~A" + (fspec->string fspec)))) + (string + (find-definition-in-buffer file)))) + +(defun fspec->string (fspec) + (etypecase fspec + (symbol (let ((*package* (find-package :keyword))) + (prin1-to-string fspec))) + (list (format nil "(~A ~A)" + (prin1-to-string (first fspec)) + (let ((*package* (find-package :keyword))) + (prin1-to-string (second fspec))))))) + +(defun fspec-definition-locations (fspec) + (cond + ((and (listp fspec) + (eql (car fspec) :top-level-form)) + (destructuring-bind (top-level-form file &optional position) fspec + (list + (list (list nil fspec) + (make-location (list :buffer file) + (list :position position t)))))) + ((and (listp fspec) (eq (car fspec) :internal)) + (destructuring-bind (_internal next _n) fspec + (fspec-definition-locations next))) + (t + (let ((defs (excl::find-source-file fspec))) + (if (null defs) + (list + (list (list nil fspec) + (list :error + (format nil "Unknown source location for ~A" + (fspec->string fspec))))) + (loop for (fspec type file top-level) in defs + collect (list (list type fspec) + (find-fspec-location fspec type file top-level)))))))) + +(defimplementation find-definitions (symbol) + (fspec-definition-locations symbol)) + +;;;; XREF + +(defmacro defxref (name relation name1 name2) + `(defimplementation ,name (x) + (xref-result (xref:get-relation ,relation ,name1 ,name2)))) + +(defxref who-calls :calls :wild x) +(defxref calls-who :calls x :wild) +(defxref who-references :uses :wild x) +(defxref who-binds :binds :wild x) +(defxref who-macroexpands :macro-calls :wild x) +(defxref who-sets :sets :wild x) + +(defun xref-result (fspecs) + (loop for fspec in fspecs + append (fspec-definition-locations fspec))) + +;; list-callers implemented by groveling through all fbound symbols. +;; Only symbols are considered. Functions in the constant pool are +;; searched recursively. Closure environments are ignored at the +;; moment (constants in methods are therefore not found). + +(defun map-function-constants (function fn depth) + "Call FN with the elements of FUNCTION's constant pool." + (do ((i 0 (1+ i)) + (max (excl::function-constant-count function))) + ((= i max)) + (let ((c (excl::function-constant function i))) + (cond ((and (functionp c) + (not (eq c function)) + (plusp depth)) + (map-function-constants c fn (1- depth))) + (t + (funcall fn c)))))) + +(defun in-constants-p (fun symbol) + (map-function-constants fun + (lambda (c) + (when (eq c symbol) + (return-from in-constants-p t))) + 3)) + +(defun function-callers (name) + (let ((callers '())) + (do-all-symbols (sym) + (when (fboundp sym) + (let ((fn (fdefinition sym))) + (when (in-constants-p fn name) + (push sym callers))))) + callers)) + +(defimplementation list-callers (name) + (xref-result (function-callers name))) + +(defimplementation list-callees (name) + (let ((result '())) + (map-function-constants (fdefinition name) + (lambda (c) + (when (fboundp c) + (push c result))) + 2) + (xref-result result))) + +;;;; Profiling + +;; Per-function profiling based on description in +;; http://www.franz.com/support/documentation/8.0/doc/runtime-analyzer.htm#dat… + +(defvar *profiled-functions* ()) +(defvar *profile-depth* 0) + +(defmacro with-redirected-y-or-n-p (&body body) + ;; If the profiler is restarted when the data from the previous + ;; session is not reported yet, the user is warned via Y-OR-N-P. + ;; As the CL:Y-OR-N-P question is (for some reason) not directly + ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily + ;; overruled. + `(let* ((pkg (find-package "common-lisp")) + (saved-pdl (excl::package-definition-lock pkg)) + (saved-ynp (symbol-function 'cl:y-or-n-p))) + + (setf (excl::package-definition-lock pkg) nil + (symbol-function 'cl:y-or-n-p) (symbol-function + (find-symbol "y-or-n-p-in-emacs" + "swank"))) + (unwind-protect + (progn ,@body) + + (setf (symbol-function 'cl:y-or-n-p) saved-ynp + (excl::package-definition-lock pkg) saved-pdl)))) + +(defun start-acl-profiler () + (with-redirected-y-or-n-p + (prof:start-profiler :type :time :count t + :start-sampling-p nil :verbose nil))) +(defun acl-profiler-active-p () + (not (eq (prof:profiler-status :verbose nil) :inactive))) + +(defun stop-acl-profiler () + (prof:stop-profiler :verbose nil)) + +(excl:def-fwrapper profile-fwrapper (&rest args) + ;; Ensures sampling is done during the execution of the function, + ;; taking into account recursion. + (declare (ignore args)) + (cond ((zerop *profile-depth*) + (let ((*profile-depth* (1+ *profile-depth*))) + (prof:start-sampling) + (unwind-protect (excl:call-next-fwrapper) + (prof:stop-sampling)))) + (t + (excl:call-next-fwrapper)))) + +(defimplementation profile (fname) + (unless (acl-profiler-active-p) + (start-acl-profiler)) + (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper) + (push fname *profiled-functions*)) + +(defimplementation profiled-functions () + *profiled-functions*) + +(defimplementation unprofile (fname) + (excl:funwrap fname 'profile-fwrapper) + (setq *profiled-functions* (remove fname *profiled-functions*))) + +(defimplementation profile-report () + (prof:show-flat-profile :verbose nil) + (when *profiled-functions* + (start-acl-profiler))) + +(defimplementation profile-reset () + (when (acl-profiler-active-p) + (stop-acl-profiler) + (start-acl-profiler)) + "Reset profiling counters.") + +;;;; Inspecting + +(defclass acl-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'acl-inspector)) + +(defmethod inspect-for-emacs ((f function) inspector) + inspector + (values "A function." + (append + (label-value-line "Name" (function-name f)) + `("Formals" ,(princ-to-string (arglist f)) (:newline)) + (let ((doc (documentation (excl::external-fn_symdef f) 'function))) + (when doc + `("Documentation:" (:newline) ,doc)))))) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + inspector + (values "A value." (allegro-inspect o))) + +(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) + inspector + (values "A function." (allegro-inspect o))) + +(defmethod inspect-for-emacs ((o standard-object) + (inspector backend-inspector)) + inspector + (values (format nil "~A is a standard-object." o) (allegro-inspect o))) + +(defun allegro-inspect (o) + (loop for (d dd) on (inspect::inspect-ctl o) + append (frob-allegro-field-def o d) + until (eq d dd))) + +(defun frob-allegro-field-def (object def) + (with-struct (inspect::field-def- name type access) def + (ecase type + ((:unsigned-word :unsigned-byte :unsigned-natural + :unsigned-long :unsigned-half-long + :unsigned-3byte) + (label-value-line name (inspect::component-ref-v object access type))) + ((:lisp :value) + (label-value-line name (inspect::component-ref object access))) + (:indirect + (destructuring-bind (prefix count ref set) access + (declare (ignore set prefix)) + (loop for i below (funcall count object) + append (label-value-line (format nil "~A-~D" name i) + (funcall ref object i)))))))) + +;;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (mp:start-scheduler) + (funcall continuation)) + +(defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + +(defvar *id-lock* (mp:make-process-lock :name "id lock")) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-process-lock (*id-lock*) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id mp:*all-processes* + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A ~D" (mp:process-whostate thread) + (mp:process-priority thread))) + +(defimplementation make-lock (&key name) + (mp:make-process-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-process-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (copy-list mp:*all-processes*)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock")) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-process-lock :name "process mailbox")) + (queue '() :type list)) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-process-lock (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (mp:process-wait-with-timeout + "yielding before sending" 0.1 + (lambda () + (mp:with-process-lock (mutex) + (< (length (mailbox.queue mbox)) 10)))) + (mp:with-process-lock (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(defimplementation receive () + (let* ((mbox (mailbox mp:*current-process*)) + (mutex (mailbox.mutex mbox))) + (mp:process-wait "receive" #'mailbox.queue mbox) + (mp:with-process-lock (mutex) + (pop (mailbox.queue mbox))))) + +(defimplementation quit-lisp () + (excl:exit 0 :quiet t)) + + +;;Trace implementations +;;In Allegro 7.0, we have: +;; (trace <name>) +;; (trace ((method <name> <qualifier>? (<specializer>+)))) +;; (trace ((labels <name> <label-name>))) +;; (trace ((labels (method <name> (<specializer>+)) <label-name>))) +;; <name> can be a normal name or a (setf name) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + (:defgeneric (toggle-trace-generic-function-methods (second spec))) + ((setf :defmethod :labels :flet) + (toggle-trace-aux (process-fspec-for-allegro spec))) + (:call + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee + :inside (list (process-fspec-for-allegro caller))))))) + +(defun tracedp (fspec) + (member fspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((tracedp fspec) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace (,fspec ,@args))) + (format nil "~S is now traced." fspec)))) + +(defun toggle-trace-generic-function-methods (name) + (let ((methods (mop:generic-function-methods (fdefinition name)))) + (cond ((tracedp name) + (eval `(untrace ,name)) + (dolist (method methods (format nil "~S is now untraced." name)) + (excl:funtrace (mop:method-function method)))) + (t + (eval `(trace (,name))) + (dolist (method methods (format nil "~S is now traced." name)) + (excl:ftrace (mop:method-function method))))))) + +(defun process-fspec-for-allegro (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((setf) fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))) + ((:flet) `(flet ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))))) + (t + fspec))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-keys t args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :values :weak args)) + +(defimplementation hash-table-weakness (hashtable) + (cond ((excl:hash-table-weak-keys hashtable) :key) + ((eq (excl:hash-table-values hashtable) :weak) :value))) + + + +;;;; Character names + +(defimplementation character-completion-set (prefix matchp) + (loop for name being the hash-keys of excl::*name-to-char-table* + when (funcall matchp prefix name) + collect (string-capitalize name))) Added: branches/trunk-reorg/thirdparty/slime/swank-backend.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-backend.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-backend.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,1077 @@ +;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- +;;; +;;; slime-backend.lisp --- SLIME backend interface. +;;; +;;; Created by James Bielman in 2003. Released into the public domain. +;;; +;;;; Frontmatter +;;; +;;; This file defines the functions that must be implemented +;;; separately for each Lisp. Each is declared as a generic function +;;; for which swank-<implementation>.lisp provides methods. + +(defpackage :swank-backend + (:use :common-lisp) + (:export #:sldb-condition + #:original-condition + #:compiler-condition + #:message + #:short-message + #:condition + #:severity + #:with-compilation-hooks + #:location + #:location-p + #:location-buffer + #:location-position + #:position-p + #:position-pos + #:print-output-to-string + #:quit-lisp + #:references + #:unbound-slot-filler + #:declaration-arglist + #:type-specifier-arglist + ;; inspector related symbols + #:inspector + #:backend-inspector + #:inspect-for-emacs + #:raw-inspection + #:fancy-inspection + #:label-value-line + #:label-value-line* + #:with-struct + )) + +(defpackage :swank-mop + (:use) + (:export + ;; classes + #:standard-generic-function + #:standard-slot-definition + #:standard-method + #:standard-class + #:eql-specializer + #:eql-specializer-object + ;; standard-class readers + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-name + #:class-precedence-list + #:class-prototype + #:class-slots + #:specializer-direct-methods + ;; generic function readers + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-methods + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-name + ;; method readers + #:method-generic-function + #:method-function + #:method-lambda-list + #:method-specializers + #:method-qualifiers + ;; slot readers + #:slot-definition-allocation + #:slot-definition-documentation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-name + #:slot-definition-type + #:slot-definition-readers + #:slot-definition-writers + #:slot-boundp-using-class + #:slot-value-using-class + #:slot-makunbound-using-class + ;; generic function protocol + #:compute-applicable-methods-using-classes + #:finalize-inheritance)) + +(in-package :swank-backend) + + +;;;; Metacode + +(defparameter *interface-functions* '() + "The names of all interface functions.") + +(defparameter *unimplemented-interfaces* '() + "List of interface functions that are not implemented. +DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.") + +(defmacro definterface (name args documentation &rest default-body) + "Define an interface function for the backend to implement. +A function is defined with NAME, ARGS, and DOCUMENTATION. This +function first looks for a function to call in NAME's property list +that is indicated by 'IMPLEMENTATION; failing that, it looks for a +function indicated by 'DEFAULT. If neither is present, an error is +signaled. + +If a DEFAULT-BODY is supplied, then a function with the same body and +ARGS will be added to NAME's property list as the property indicated +by 'DEFAULT. + +Backends implement these functions using DEFIMPLEMENTATION." + (check-type documentation string "a documentation string") + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + (labels ((gen-default-impl () + `(setf (get ',name 'default) (lambda ,args ,@default-body))) + (args-as-list (args) + (destructuring-bind (req opt key rest) (parse-lambda-list args) + `(,@req ,@opt + ,@(loop for k in key append `(,(kw k) ,k)) + ,@(or rest '(()))))) + (parse-lambda-list (args) + (parse args '(&optional &key &rest) + (make-array 4 :initial-element nil))) + (parse (args keywords vars) + (cond ((null args) + (reverse (map 'list #'reverse vars))) + ((member (car args) keywords) + (parse (cdr args) (cdr (member (car args) keywords)) vars)) + (t (push (car args) (aref vars (length keywords))) + (parse (cdr args) keywords vars)))) + (kw (s) (intern (string s) :keyword))) + `(progn + (defun ,name ,args + ,documentation + (let ((f (or (get ',name 'implementation) + (get ',name 'default)))) + (cond (f (apply f ,@(args-as-list args))) + (t (error "~S not implementated" ',name))))) + (pushnew ',name *interface-functions*) + ,(if (null default-body) + `(pushnew ',name *unimplemented-interfaces*) + (gen-default-impl)) + ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler…> + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name :swank-backend)) + ',name))) + +(defmacro defimplementation (name args &body body) + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + `(progn + (setf (get ',name 'implementation) (lambda ,args ,@body)) + (if (member ',name *interface-functions*) + (setq *unimplemented-interfaces* + (remove ',name *unimplemented-interfaces*)) + (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name)) + ',name)) + +(defun warn-unimplemented-interfaces () + "Warn the user about unimplemented backend features. +The portable code calls this function at startup." + (warn "These Swank interfaces are unimplemented:~% ~A" + (sort (copy-list *unimplemented-interfaces*) #'string<))) + +(defun import-to-swank-mop (symbol-list) + (dolist (sym symbol-list) + (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop))) + (when swank-mop-sym + (unintern swank-mop-sym :swank-mop)) + (import sym :swank-mop) + (export sym :swank-mop)))) + +(defun import-swank-mop-symbols (package except) + "Import the mop symbols from PACKAGE to SWANK-MOP. +EXCEPT is a list of symbol names which should be ignored." + (do-symbols (s :swank-mop) + (unless (member s except :test #'string=) + (let ((real-symbol (find-symbol (string s) package))) + (assert real-symbol () "Symbol ~A not found in package ~A" s package) + (unintern s :swank-mop) + (import real-symbol :swank-mop) + (export real-symbol :swank-mop))))) + +(defvar *gray-stream-symbols* + '(:fundamental-character-output-stream + :stream-write-char + :stream-fresh-line + :stream-force-output + :stream-finish-output + :fundamental-character-input-stream + :stream-read-char + :stream-listen + :stream-unread-char + :stream-clear-input + :stream-line-column + :stream-read-char-no-hang + ;; STREAM-LINE-LENGTH is an extension to gray streams that's apparently + ;; supported by CMUCL, OpenMCL, SBCL and SCL. + #+(or cmu openmcl sbcl scl) + :stream-line-length)) + +(defun import-from (package symbol-names &optional (to-package *package*)) + "Import the list of SYMBOL-NAMES found in the package PACKAGE." + (dolist (name symbol-names) + (multiple-value-bind (symbol found) (find-symbol (string name) package) + (assert found () "Symbol ~A not found in package ~A" name package) + (import symbol to-package)))) + + +;;;; Utilities + +(defmacro with-struct ((conc-name &rest names) obj &body body) + "Like with-slots but works only for structs." + (flet ((reader (slot) (intern (concatenate 'string + (symbol-name conc-name) + (symbol-name slot)) + (symbol-package conc-name)))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + ,@body))))) + + +;;;; TCP server + +(definterface create-socket (host port) + "Create a listening TCP socket on interface HOST and port PORT .") + +(definterface local-port (socket) + "Return the local port number of SOCKET.") + +(definterface close-socket (socket) + "Close the socket SOCKET.") + +(definterface accept-connection (socket &key external-format + buffering timeout) + "Accept a client connection on the listening socket SOCKET. +Return a stream for the new connection.") + +(definterface add-sigio-handler (socket fn) + "Call FN whenever SOCKET is readable.") + +(definterface remove-sigio-handlers (socket) + "Remove all sigio handlers for SOCKET.") + +(definterface add-fd-handler (socket fn) + "Call FN when Lisp is waiting for input and SOCKET is readable.") + +(definterface remove-fd-handlers (socket) + "Remove all fd-handlers for SOCKET.") + +(definterface preferred-communication-style () + "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL." + nil) + +(definterface set-stream-timeout (stream timeout) + "Set the 'stream 'timeout. The timeout is either the real number + specifying the timeout in seconds or 'nil for no timeout." + (declare (ignore stream timeout)) + nil) + +;;; Base condition for networking errors. +(define-condition network-error (simple-error) ()) + +(definterface emacs-connected () + "Hook called when the first connection from Emacs is established. +Called from the INIT-FN of the socket server that accepts the +connection. + +This is intended for setting up extra context, e.g. to discover +that the calling thread is the one that interacts with Emacs." + nil) + + +;;;; Unix signals + +(defconstant +sigint+ 2) + +(definterface call-without-interrupts (fn) + "Call FN in a context where interrupts are disabled." + (funcall fn)) + +(definterface getpid () + "Return the (Unix) process ID of this superior Lisp.") + +(definterface lisp-implementation-type-name () + "Return a short name for the Lisp implementation." + (lisp-implementation-type)) + +(definterface default-directory () + "Return the default directory." + (directory-namestring (truename *default-pathname-defaults*))) + +(definterface set-default-directory (directory) + "Set the default directory. +This is used to resolve filenames without directory component." + (setf *default-pathname-defaults* (truename (merge-pathnames directory))) + (default-directory)) + +(definterface call-with-syntax-hooks (fn) + "Call FN with hooks to handle special syntax." + (funcall fn)) + +(definterface default-readtable-alist () + "Return a suitable initial value for SWANK:*READTABLE-ALIST*." + '()) + +(definterface quit-lisp () + "Exit the current lisp image.") + + +;;;; Compilation + +(definterface call-with-compilation-hooks (func) + "Call FUNC with hooks to record compiler conditions.") + +(defmacro with-compilation-hooks ((&rest ignore) &body body) + "Execute BODY as in CALL-WITH-COMPILATION-HOOKS." + (declare (ignore ignore)) + `(call-with-compilation-hooks (lambda () (progn ,@body)))) + +(definterface swank-compile-string (string &key buffer position directory) + "Compile source from STRING. During compilation, compiler +conditions must be trapped and resignalled as COMPILER-CONDITIONs. + +If supplied, BUFFER and POSITION specify the source location in Emacs. + +Additionally, if POSITION is supplied, it must be added to source +positions reported in compiler conditions. + +If DIRECTORY is specified it may be used by certain implementations to +rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of +source information.") + +(definterface swank-compile-file (filename load-p external-format) + "Compile FILENAME signalling COMPILE-CONDITIONs. +If LOAD-P is true, load the file after compilation. +EXTERNAL-FORMAT is a value returned by find-external-format or +:default.") + +(deftype severity () + '(member :error :read-error :warning :style-warning :note)) + +;; Base condition type for compiler errors, warnings and notes. +(define-condition compiler-condition (condition) + ((original-condition + ;; The original condition thrown by the compiler if appropriate. + ;; May be NIL if a compiler does not report using conditions. + :type (or null condition) + :initarg :original-condition + :accessor original-condition) + + (severity :type severity + :initarg :severity + :accessor severity) + + (message :initarg :message + :accessor message) + + (short-message :initarg :short-message + :initform nil + :accessor short-message) + + (references :initarg :references + :initform nil + :accessor references) + + (location :initarg :location + :accessor location))) + +(definterface find-external-format (coding-system) + "Return a \"external file format designator\" for CODING-SYSTEM. +CODING-SYSTEM is Emacs-style coding system name (a string), +e.g. \"latin-1-unix\"." + (if (equal coding-system "iso-latin-1-unix") + :default + nil)) + +(definterface guess-external-format (filename) + "Detect the external format for the file with name FILENAME. +Return nil if the file contains no special markers." + ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section. + (with-open-file (s filename :if-does-not-exist nil + :external-format (or (find-external-format "latin-1-unix") + :default)) + (if s + (or (let* ((line (read-line s nil)) + (p (search "-*-" line))) + (when p + (let* ((start (+ p (length "-*-"))) + (end (search "-*-" line :start2 start))) + (when end + (%search-coding line start end))))) + (let* ((len (file-length s)) + (buf (make-string (min len 3000)))) + (file-position s (- len (length buf))) + (read-sequence buf s) + (let ((start (search "Local Variables:" buf :from-end t)) + (end (search "End:" buf :from-end t))) + (and start end (< start end) + (%search-coding buf start end)))))))) + +(defun %search-coding (str start end) + (let ((p (search "coding:" str :start2 start :end2 end))) + (when p + (incf p (length "coding:")) + (loop while (and (< p end) + (member (aref str p) '(#\space #\tab))) + do (incf p)) + (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline))) + str :start p))) + (find-external-format (subseq str p end)))))) + + +;;;; Streams + +(definterface make-fn-streams (input-fn output-fn) + "Return character input and output streams backended by functions. +When input is needed, INPUT-FN is called with no arguments to +return a string. +When output is ready, OUTPUT-FN is called with the output as its +argument. + +Output should be forced to OUTPUT-FN before calling INPUT-FN. + +The streams are returned as two values.") + +(definterface make-stream-interactive (stream) + "Do any necessary setup to make STREAM work interactively. +This is called for each stream used for interaction with the user +\(e.g. *standard-output*). An implementation could setup some +implementation-specific functions to control output flushing at the +like." + (declare (ignore stream)) + nil) + + +;;;; Documentation + +(definterface arglist (name) + "Return the lambda list for the symbol NAME. NAME can also be +a lisp function object, on lisps which support this. + +The result can be a list or the :not-available keyword if the +arglist cannot be determined." + (declare (ignore name)) + :not-available) + +(defgeneric declaration-arglist (decl-identifier) + (:documentation + "Return the argument list of the declaration specifier belonging to the +declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined, +the keyword :NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (decl-identifier) + (case decl-identifier + (dynamic-extent '(&rest vars)) + (ignore '(&rest vars)) + (ignorable '(&rest vars)) + (special '(&rest vars)) + (inline '(&rest function-names)) + (notinline '(&rest function-name)) + (optimize '(&any compilation-speed debug safety space speed)) + (type '(type-specifier &rest args)) + (ftype '(type-specifier &rest function-names)) + (otherwise + (flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol)))) + (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier)) + '(&rest vars)) + ((and (listp decl-identifier) (typespec-p (first decl-identifier))) + '(&rest vars)) + (t :not-available))))))) + +(defgeneric type-specifier-arglist (typespec-operator) + (:documentation + "Return the argument list of the type specifier belonging to +TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword +:NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (typespec-operator) + (declare (special *type-specifier-arglists*)) ; defined at end of file. + (typecase typespec-operator + (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*)) + :not-available)) + (t :not-available)))) + +(definterface function-name (function) + "Return the name of the function object FUNCTION. + +The result is either a symbol, a list, or NIL if no function name is available." + (declare (ignore function)) + nil) + +(definterface macroexpand-all (form) + "Recursively expand all macros in FORM. +Return the resulting form.") + +(definterface compiler-macroexpand-1 (form &optional env) + "Call the compiler-macro for form. +If FORM is a function call for which a compiler-macro has been +defined, invoke the expander function using *macroexpand-hook* and +return the results and T. Otherwise, return the original form and +NIL." + (let ((fun (and (consp form) (compiler-macro-function (car form))))) + (if fun + (let ((result (funcall *macroexpand-hook* fun form env))) + (values result (not (eq result form)))) + (values form nil)))) + +(definterface compiler-macroexpand (form &optional env) + "Repetitively call `compiler-macroexpand-1'." + (labels ((frob (form expanded) + (multiple-value-bind (new-form newly-expanded) + (compiler-macroexpand-1 form env) + (if newly-expanded + (frob new-form t) + (values new-form expanded))))) + (frob form env))) + +(definterface describe-symbol-for-emacs (symbol) + "Return a property list describing SYMBOL. + +The property list has an entry for each interesting aspect of the +symbol. The recognised keys are: + + :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO + :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM + +The value of each property is the corresponding documentation string, +or :NOT-DOCUMENTED. It is legal to include keys not listed here (but +slime-print-apropos in Emacs must know about them). + +Properties should be included if and only if they are applicable to +the symbol. For example, only (and all) fbound symbols should include +the :FUNCTION property. + +Example: +\(describe-symbol-for-emacs 'vector) + => (:CLASS :NOT-DOCUMENTED + :TYPE :NOT-DOCUMENTED + :FUNCTION \"Constructs a simple-vector from the given objects.\")") + +(definterface describe-definition (name type) + "Describe the definition NAME of TYPE. +TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS. + +Return a documentation string, or NIL if none is available.") + + +;;;; Debugging + +(definterface install-debugger-globally (function) + "Install FUNCTION as the debugger for all threads/processes. This +usually involves setting *DEBUGGER-HOOK* and, if the implementation +permits, hooking into BREAK as well." + (setq *debugger-hook* function)) + +(definterface call-with-debugging-environment (debugger-loop-fn) + "Call DEBUGGER-LOOP-FN in a suitable debugging environment. + +This function is called recursively at each debug level to invoke the +debugger loop. The purpose is to setup any necessary environment for +other debugger callbacks that will be called within the debugger loop. + +For example, this is a reasonable place to compute a backtrace, switch +to safe reader/printer settings, and so on.") + +(definterface call-with-debugger-hook (hook fun) + "Call FUN and use HOOK as debugger hook. + +HOOK should be called for both BREAK and INVOKE-DEBUGGER." + (let ((*debugger-hook* hook)) + (funcall fun))) + +(define-condition sldb-condition (condition) + ((original-condition + :initarg :original-condition + :accessor original-condition)) + (:report (lambda (condition stream) + (format stream "Condition in debugger code~@[: ~A~]" + (original-condition condition)))) + (:documentation + "Wrapper for conditions that should not be debugged. + +When a condition arises from the internals of the debugger, it is not +desirable to debug it -- we'd risk entering an endless loop trying to +debug the debugger! Instead, such conditions can be reported to the +user without (re)entering the debugger by wrapping them as +`sldb-condition's.")) + +(definterface compute-backtrace (start end) + "Return a list containing a backtrace of the condition current +being debugged. The results are unspecified if this function is +called outside the dynamic contour CALL-WITH-DEBUGGING-ENVIRONMENT. + +START and END are zero-based indices constraining the number of frames +returned. Frame zero is defined as the frame which invoked the +debugger. If END is nil, return the frames from START to the end of +the stack.") + +(definterface compute-sane-restarts (condition) + "This is an opportunity for Lisps such as CLISP to remove +unwanted restarts from the output of CL:COMPUTE-RESTARTS, +otherwise it should simply call CL:COMPUTE-RESTARTS, which is +what the default implementation does." + (compute-restarts condition)) + +(definterface print-frame (frame stream) + "Print frame to stream.") + +(definterface frame-source-location-for-emacs (frame-number) + "Return the source location for FRAME-NUMBER.") + +(definterface frame-catch-tags (frame-number) + "Return a list of XXX list of what? catch tags for a debugger +stack frame. The results are undefined unless this is called +within the dynamic contour of a function defined by +DEFINE-DEBUGGER-HOOK.") + +(definterface frame-locals (frame-number) + "Return a list of XXX local variable designators define me +for a debugger stack frame. The results are undefined unless +this is called within the dynamic contour of a function defined +by DEFINE-DEBUGGER-HOOK.") + +(definterface frame-var-value (frame var) + "Return the value of VAR in FRAME. +FRAME is the number of the frame in the backtrace. +VAR is the number of the variable in the frame.") + +(definterface disassemble-frame (frame-number) + "Disassemble the code for the FRAME-NUMBER. +The output should be written to standard output. +FRAME-NUMBER is a non-negative integer.") + +(definterface eval-in-frame (form frame-number) + "Evaluate a Lisp form in the lexical context of a stack frame +in the debugger. The results are undefined unless called in the +dynamic contour of a function defined by DEFINE-DEBUGGER-HOOK. + +FRAME-NUMBER must be a positive integer with 0 indicating the +frame which invoked the debugger. + +The return value is the result of evaulating FORM in the +appropriate context.") + +(definterface return-from-frame (frame-number form) + "Unwind the stack to the frame FRAME-NUMBER and return the value(s) +produced by evaluating FORM in the frame context to its caller. + +Execute any clean-up code from unwind-protect forms above the frame +during unwinding. + +Return a string describing the error if it's not possible to return +from the frame.") + +(definterface restart-frame (frame-number) + "Restart execution of the frame FRAME-NUMBER with the same arguments +as it was called originally.") + +(definterface format-sldb-condition (condition) + "Format a condition for display in SLDB." + (princ-to-string condition)) + +(definterface condition-extras (condition) + "Return a list of extra for the debugger. +The allowed elements are of the form: + (:SHOW-FRAME-SOURCE frame-number) + (:REFERENCES &rest refs) +" + (declare (ignore condition)) + '()) + +(definterface activate-stepping (frame-number) + "Prepare the frame FRAME-NUMBER for stepping.") + +(definterface sldb-break-on-return (frame-number) + "Set a breakpoint in the frame FRAME-NUMBER.") + +(definterface sldb-break-at-start (symbol) + "Set a breakpoint on the beginning of the function for SYMBOL.") + +(definterface sldb-stepper-condition-p (condition) + "Return true if SLDB was invoked due to a single-stepping condition, +false otherwise. " + (declare (ignore condition)) + nil) + +(definterface sldb-step-into () + "Step into the current single-stepper form.") + +(definterface sldb-step-next () + "Step to the next form in the current function.") + +(definterface sldb-step-out () + "Stop single-stepping temporarily, but resume it once the current function +returns.") + + +;;;; Definition finding + +(defstruct (:location (:type list) :named + (:constructor make-location + (buffer position &optional hints))) + buffer position + ;; Hints is a property list optionally containing: + ;; :snippet SOURCE-TEXT + ;; This is a snippet of the actual source text at the start of + ;; the definition, which could be used in a text search. + hints) + +(defstruct (:error (:type list) :named (:constructor)) message) +(defstruct (:file (:type list) :named (:constructor)) name) +(defstruct (:buffer (:type list) :named (:constructor)) name) +(defstruct (:position (:type list) :named (:constructor)) pos) + +(definterface find-definitions (name) + "Return a list ((DSPEC LOCATION) ...) for NAME's definitions. + +NAME is a \"definition specifier\". + +DSPEC is a \"definition specifier\" describing the +definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or +\(DEFVAR FOO). + +LOCATION is the source location for the definition.") + +(definterface buffer-first-change (filename) + "Called for effect the first time FILENAME's buffer is modified." + (declare (ignore filename)) + nil) + + +;;;; XREF + +(definterface who-calls (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...).") + +(definterface calls-who (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...).") + +(definterface who-references (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is referenced. +See WHO-CALLS for a description of the return value.") + +(definterface who-binds (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is bound. +See WHO-CALLS for a description of the return value.") + +(definterface who-sets (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is set. +See WHO-CALLS for a description of the return value.") + +(definterface who-macroexpands (macro-name) + "Return the locations where MACRO-NAME (a symbol) is expanded. +See WHO-CALLS for a description of the return value.") + +(definterface who-specializes (class-name) + "Return the locations where CLASS-NAME (a symbol) is specialized. +See WHO-CALLS for a description of the return value.") + +;;; Simpler variants. + +(definterface list-callers (function-name) + "List the callers of FUNCTION-NAME. +This function is like WHO-CALLS except that it is expected to use +lower-level means. Whereas WHO-CALLS is usually implemented with +special compiler support, LIST-CALLERS is usually implemented by +groveling for constants in function objects throughout the heap. + +The return value is as for WHO-CALLS.") + +(definterface list-callees (function-name) + "List the functions called by FUNCTION-NAME. +See LIST-CALLERS for a description of the return value.") + + +;;;; Profiling + +;;; The following functions define a minimal profiling interface. + +(definterface profile (fname) + "Marks symbol FNAME for profiling.") + +(definterface profiled-functions () + "Returns a list of profiled functions.") + +(definterface unprofile (fname) + "Marks symbol FNAME as not profiled.") + +(definterface unprofile-all () + "Marks all currently profiled functions as not profiled." + (dolist (f (profiled-functions)) + (unprofile f))) + +(definterface profile-report () + "Prints profile report.") + +(definterface profile-reset () + "Resets profile counters.") + +(definterface profile-package (package callers-p methods) + "Wrap profiling code around all functions in PACKAGE. If a function +is already profiled, then unprofile and reprofile (useful to notice +function redefinition.) + +If CALLERS-P is T names have counts of the most common calling +functions recorded. + +When called with arguments :METHODS T, profile all methods of all +generic functions having names in the given package. Generic functions +themselves, that is, their dispatch functions, are left alone.") + + +;;;; Inspector + +(defclass inspector () + () + (:documentation "Super class of inspector objects. + +Implementations should sub class in order to dispatch off of the +inspect-for-emacs method.")) + +(defclass backend-inspector (inspector) ()) + +(definterface make-default-inspector () + "Return an inspector object suitable for passing to inspect-for-emacs.") + +(defgeneric inspect-for-emacs (object inspector) + (:documentation + "Explain to Emacs how to inspect OBJECT. + +The argument INSPECTOR is an object representing how to get at +the internals of OBJECT, it is usually an implementation specific +class used simply for dispatching to the proper method. + +Returns two values: a string which will be used as the title of +the inspector buffer and a list specifying how to render the +object for inspection. + +Every element of the list must be either a string, which will be +inserted into the buffer as is, or a list of the form: + + (:value object &optional format) - Render an inspectable + object. If format is provided it must be a string and will be + rendered in place of the value, otherwise use princ-to-string. + + (:newline) - Render a \\n + + (:action label lambda &key (refresh t)) - Render LABEL (a text + string) which when clicked will call LAMBDA. If REFRESH is + non-NIL the currently inspected object will be re-inspected + after calling the lambda. + + NIL - do nothing.")) + +(defmethod inspect-for-emacs ((object t) (inspector t)) + "Generic method for inspecting any kind of object. + +Since we don't know how to deal with OBJECT we simply dump the +output of CL:DESCRIBE." + (declare (ignore inspector)) + (values + "A value." + `("Type: " (:value ,(type-of object)) (:newline) + "Don't know how to inspect the object, dumping output of CL:DESCRIBE:" + (:newline) (:newline) + ,(with-output-to-string (desc) (describe object desc))))) + +;;; Utilities for inspector methods. +;;; +(defun label-value-line (label value &key (newline t)) + "Create a control list which prints \"LABEL: VALUE\" in the inspector. +If NEWLINE is non-NIL a `(:newline)' is added to the result." + (list* (princ-to-string label) ": " `(:value ,value) + (if newline '((:newline)) nil))) + +(defmacro label-value-line* (&rest label-values) + ` (append ,@(loop for (label value) in label-values + collect `(label-value-line ,label ,value)))) + +(definterface describe-primitive-type (object) + "Return a string describing the primitive type of object." + (declare (ignore object)) + "N/A") + + +;;;; Multithreading +;;; +;;; The default implementations are sufficient for non-multiprocessing +;;; implementations. + +(definterface initialize-multiprocessing (continuation) + "Initialize multiprocessing, if necessary and then invoke CONTINUATION. + +Depending on the impleimentaion, this function may never return." + (funcall continuation)) + +(definterface spawn (fn &key name) + "Create a new thread to call FN.") + +(definterface thread-id (thread) + "Return an Emacs-parsable object to identify THREAD. + +Ids should be comparable with equal, i.e.: + (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)") + +(definterface find-thread (id) + "Return the thread for ID. +ID should be an id previously obtained with THREAD-ID. +Can return nil if the thread no longer exists.") + +(definterface thread-name (thread) + "Return the name of THREAD. + +Thread names are be single-line strings and are meaningful to the +user. They do not have to be unique." + (declare (ignore thread)) + "The One True Thread") + +(definterface thread-status (thread) + "Return a string describing THREAD's state." + (declare (ignore thread)) + "") + +(definterface make-lock (&key name) + "Make a lock for thread synchronization. +Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time." + (declare (ignore name)) + :null-lock) + +(definterface call-with-lock-held (lock function) + "Call FUNCTION with LOCK held, queueing if necessary." + (declare (ignore lock) + (type function function)) + (funcall function)) + +(definterface make-recursive-lock (&key name) + "Make a lock for thread synchronization. +Only one thread may hold the lock (via CALL-WITH-RECURSIVE-LOCK-HELD) +at a time, but that thread may hold it more than once." + (cons nil (make-lock :name name))) + +(definterface call-with-recursive-lock-held (lock function) + "Call FUNCTION with LOCK held, queueing if necessary." + (if (eql (car lock) (current-thread)) + (funcall function) + (call-with-lock-held (cdr lock) + (lambda () + (unwind-protect + (progn + (setf (car lock) (current-thread)) + (funcall function)) + (setf (car lock) nil)))))) + +(definterface current-thread () + "Return the currently executing thread." + 0) + +(definterface all-threads () + "Return a list of all threads.") + +(definterface thread-alive-p (thread) + "Test if THREAD is termintated." + (member thread (all-threads))) + +(definterface interrupt-thread (thread fn) + "Cause THREAD to execute FN.") + +(definterface kill-thread (thread) + "Kill THREAD." + (declare (ignore thread)) + nil) + +(definterface send (thread object) + "Send OBJECT to thread THREAD.") + +(definterface receive () + "Return the next message from current thread's mailbox.") + +(definterface toggle-trace (spec) + "Toggle tracing of the function(s) given with SPEC. +SPEC can be: + (setf NAME) ; a setf function + (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method + (:defgeneric NAME) ; a generic function with all methods + (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. + (:labels TOPLEVEL LOCAL) + (:flet TOPLEVEL LOCAL) ") + + +;;;; Weak datastructures + +(definterface make-weak-key-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the keys." + (apply #'make-hash-table args)) + +(definterface make-weak-value-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the values." + (apply #'make-hash-table args)) + +(definterface hash-table-weakness (hashtable) + "Return nil or one of :key :value :key-or-value :key-and-value" + (declare (ignore hashtable)) + nil) + + +;;;; Character names + +(definterface character-completion-set (prefix matchp) + "Return a list of names of characters that match PREFIX." + ;; Handle the standard and semi-standard characters. + (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout" + "Linefeed" "Return" "Backspace") + when (funcall matchp prefix name) + collect name)) + + +(defparameter *type-specifier-arglists* + '((and . (&rest type-specifiers)) + (array . (&optional element-type dimension-spec)) + (base-string . (&optional size)) + (bit-vector . (&optional size)) + (complex . (&optional type-specifier)) + (cons . (&optional car-typespec cdr-typespec)) + (double-float . (&optional lower-limit upper-limit)) + (eql . (object)) + (float . (&optional lower-limit upper-limit)) + (function . (&optional arg-typespec value-typespec)) + (integer . (&optional lower-limit upper-limit)) + (long-float . (&optional lower-limit upper-limit)) + (member . (&rest eql-objects)) + (mod . (n)) + (not . (type-specifier)) + (or . (&rest type-specifiers)) + (rational . (&optional lower-limit upper-limit)) + (real . (&optional lower-limit upper-limit)) + (satisfies . (predicate-symbol)) + (short-float . (&optional lower-limit upper-limit)) + (signed-byte . (&optional size)) + (simple-array . (&optional element-type dimension-spec)) + (simple-base-string . (&optional size)) + (simple-bit-vector . (&optional size)) + (simple-string . (&optional size)) + (single-float . (&optional lower-limit upper-limit)) + (simple-vector . (&optional size)) + (string . (&optional size)) + (unsigned-byte . (&optional size)) + (values . (&rest typespecs)) + (vector . (&optional element-type size)) + )) Added: branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,672 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +;;;; SWANK support for CLISP. + +;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach + +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License as +;;;; published by the Free Software Foundation; either version 2 of +;;;; the License, or (at your option) any later version. + +;;;; This program 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 General Public License for more details. + +;;;; You should have received a copy of the GNU General Public +;;;; License along with this program; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;;;; MA 02111-1307, USA. + +;;; This is work in progress, but it's already usable. Many things +;;; are adapted from other swank-*.lisp, in particular from +;;; swank-allegro (I don't use allegro at all, but it's the shortest +;;; one and I found Helmut Eller's code there enlightening). + +;;; This code will work better with recent versions of CLISP (say, the +;;; last release or CVS HEAD) while it may not work at all with older +;;; versions. It is reasonable to expect it to work on platforms with +;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like +;;; systems, but also on Win32. This backend uses the portable xref +;;; from the CMU AI repository and metering.lisp from CLOCC [1], which +;;; are conveniently included in SLIME. + +;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/ + +(in-package :swank-backend) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;;(use-package "SOCKET") + (use-package "GRAY")) + +;;;; if this lisp has the complete CLOS then we use it, otherwise we +;;;; build up a "fake" swank-mop and then override the methods in the +;;;; inspector. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *have-mop* + (and (find-package :clos) + (eql :external + (nth-value 1 (find-symbol (string ':standard-slot-definition) + :clos)))) + "True in those CLISP images which have a complete MOP implementation.")) + +#+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or)) +(progn + (import-swank-mop-symbols :clos '(:slot-definition-documentation)) + + (defun swank-mop:slot-definition-documentation (slot) + (clos::slot-definition-documentation slot))) + +#-#.(cl:if swank-backend::*have-mop* '(and) '(or)) +(defclass swank-mop:standard-slot-definition () + () + (:documentation + "Dummy class created so that swank.lisp will compile and load.")) + +;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or)) +;; (progn +;; (defmacro with-blocked-signals ((&rest signals) &body body) +;; (ext:with-gensyms ("SIGPROCMASK" ret mask) +;; `(multiple-value-bind (,ret ,mask) +;; (linux:sigprocmask-set-n-save +;; ,linux:SIG_BLOCK +;; ,(do ((sigset (linux:sigset-empty) +;; (linux:sigset-add sigset (the fixnum (pop signals))))) +;; ((null signals) sigset))) +;; (linux:check-res ,ret 'linux:sigprocmask-set-n-save) +;; (unwind-protect +;; (progn ,@body) +;; (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil))))) + +;; (defimplementation call-without-interrupts (fn) +;; (with-blocked-signals (#.linux:SIGINT) (funcall fn)))) + +;; #+#.(cl:if (cl:find-package "LINUX") '(or) '(and)) +(defimplementation call-without-interrupts (fn) + (funcall fn)) + +(let ((getpid (or (find-symbol "PROCESS-ID" :system) + ;; old name prior to 2005-03-01, clisp <= 2.33.2 + (find-symbol "PROGRAM-ID" :system) + #+win32 ; integrated into the above since 2005-02-24 + (and (find-package :win32) ; optional modules/win32 + (find-symbol "GetCurrentProcessId" :win32))))) + (defimplementation getpid () ; a required interface + (cond + (getpid (funcall getpid)) + #+win32 ((ext:getenv "PID")) ; where does that come from? + (t -1)))) + +(defimplementation lisp-implementation-type-name () + "clisp") + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) directory) + (namestring (setf *default-pathname-defaults* (ext:default-directory)))) + +;;;; TCP Server + +(defimplementation create-socket (host port) + (declare (ignore host)) + (socket:socket-server port)) + +(defimplementation local-port (socket) + (socket:socket-server-port socket)) + +(defimplementation close-socket (socket) + (socket:socket-server-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout)) + (socket:socket-accept socket + :buffered nil ;; XXX should be t + :element-type 'character + :external-format external-format)) + +;;;; Coding systems + +(defvar *external-format-to-coding-system* + '(((:charset "iso-8859-1" :line-terminator :unix) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + ((:charset "iso-8859-1":latin-1) + "latin-1" "iso-latin-1" "iso-8859-1") + ((:charset "utf-8") "utf-8") + ((:charset "utf-8" :line-terminator :unix) "utf-8-unix") + ((:charset "euc-jp") "euc-jp") + ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix") + ((:charset "us-ascii") "us-ascii") + ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (let ((args (car (rassoc-if (lambda (x) + (member coding-system x :test #'equal)) + *external-format-to-coding-system*)))) + (and args (apply #'ext:make-encoding args)))) + + +;;;; Swank functions + +(defimplementation arglist (fname) + (block nil + (or (ignore-errors + (let ((exp (function-lambda-expression fname))) + (and exp (return (second exp))))) + (ignore-errors + (return (ext:arglist fname))) + :not-available))) + +(defimplementation macroexpand-all (form) + (ext:expand-form form)) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result ())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push :variable (when (boundp symbol) (doc 'variable))) + (when (fboundp symbol) + (maybe-push + ;; Report WHEN etc. as macros, even though they may be + ;; implemented as special operators. + (if (macro-function symbol) :macro + (typecase (fdefinition symbol) + (generic-function :generic-function) + (function :function) + ;; (type-of 'progn) -> ext:special-operator + (t :special-operator))) + (doc 'function))) + (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt) + (get symbol 'system::setf-expander)); defsetf + (maybe-push :setf (doc 'setf))) + (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp + (get symbol 'system::defstruct-description) + (get symbol 'system::deftype-expander)) + (maybe-push :type (doc 'type))) ; even for 'structure + (when (find-class symbol nil) + (maybe-push :class (doc 'type))) + ;; Let this code work compiled in images without FFI + (let ((types (load-time-value + (and (find-package "FFI") + (symbol-value + (find-symbol "*C-TYPE-TABLE*" "FFI")))))) + ;; Use ffi::*c-type-table* so as not to suffer the overhead of + ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols + ;; which are not FFI type names. + (when (and types (nth-value 1 (gethash symbol types))) + ;; Maybe use (case (head (ffi:deparse-c-type))) + ;; to distinguish struct and union types? + (maybe-push :alien-type :not-documented))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable (describe symbol)) + (:macro (describe (macro-function symbol))) + (:function (describe (symbol-function symbol))) + (:class (describe (find-class symbol))))) + +(defun fspec-pathname (symbol) + (let ((path (documentation symbol 'sys::file)) + lines) + (when (consp path) + (psetq path (car path) + lines (cdr path))) + (when (and path + (member (pathname-type path) + custom:*compiled-file-types* :test #'equal)) + (setq path + (loop for suffix in custom:*source-file-types* + thereis (probe-file (make-pathname :defaults path + :type suffix))))) + (values path lines))) + +(defun fspec-location (fspec) + (multiple-value-bind (file lines) + (fspec-pathname fspec) + (cond (file + (multiple-value-bind (truename c) (ignore-errors (truename file)) + (cond (truename + (make-location (list :file (namestring truename)) + (if (consp lines) + (list* :line lines) + (list :function-name (string fspec))))) + (t (list :error (princ-to-string c)))))) + (t (list :error (format nil "No source information available for: ~S" + fspec)))))) + +(defimplementation find-definitions (name) + (list (list name (fspec-location name)))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defvar *sldb-backtrace*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* (;;(sys::*break-count* (1+ sys::*break-count*)) + ;;(sys::*driver* debugger-loop-fn) + ;;(sys::*fasoutput-stream* nil) + (*sldb-backtrace* + (nthcdr 3 (member (sys::the-frame) (sldb-backtrace))))) + (funcall debugger-loop-fn))) + +(defun nth-frame (index) + (nth index *sldb-backtrace*)) + +(defun sldb-backtrace () + "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." + (do ((frames '()) + (last nil frame) + (frame (sys::the-frame) (sys::frame-up-1 frame 1))) ; 1 = "all frames" + ((eq frame last) (nreverse frames)) + (unless (boring-frame-p frame) + (push frame frames)))) + +(defun boring-frame-p (frame) + (member (frame-type frame) '(stack-value bind-var bind-env))) + +(defun frame-to-string (frame) + (with-output-to-string (s) + (sys::describe-frame s frame))) + +(defun frame-type (frame) + ;; FIXME: should bind *print-length* etc. to small values. + (frame-string-type (frame-to-string frame))) + +(defvar *frame-prefixes* + '(("frame binding variables" bind-var) + ("<1> #<compiled-function" compiled-fun) + ("<1> #<system-function" sys-fun) + ("<1> #<special-operator" special-op) + ("EVAL frame" eval) + ("APPLY frame" apply) + ("compiled tagbody frame" compiled-tagbody) + ("compiled block frame" compiled-block) + ("block frame" block) + ("nested block frame" block) + ("tagbody frame" tagbody) + ("nested tagbody frame" tagbody) + ("catch frame" catch) + ("handler frame" handler) + ("unwind-protect frame" unwind-protect) + ("driver frame" driver) + ("frame binding environments" bind-env) + ("CALLBACK frame" callback) + ("- " stack-value) + ("<1> " fun) + ("<2> " 2nd-frame))) + +(defun frame-string-type (string) + (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string)) + *frame-prefixes*))) + +(defimplementation compute-backtrace (start end) + (let* ((bt *sldb-backtrace*) + (len (length bt))) + (subseq bt start (min (or end len) len)))) + +;;; CLISP's REPL sets up an ABORT restart that kills SWANK. Here we +;;; can omit that restart so that users don't select it by mistake. +(defimplementation compute-sane-restarts (condition) + ;; The outermost restart is specified to be the last element of the + ;; list, hopefully that's our unwanted ABORT restart. + (butlast (compute-restarts condition))) + +(defimplementation print-frame (frame stream) + (let ((str (frame-to-string frame))) + ;; (format stream "~A " (frame-string-type str)) + (write-string (extract-frame-line str) + stream))) + +(defun extract-frame-line (frame-string) + (let ((s frame-string)) + (trim-whitespace + (case (frame-string-type s) + ((eval special-op) + (string-match "EVAL frame .*for form \$.*\$" s 1)) + (apply + (string-match "APPLY frame for call \$.*\$" s 1)) + ((compiled-fun sys-fun fun) + (extract-function-name s)) + (t s))))) + +(defun extract-function-name (string) + (let ((1st (car (split-frame-string string)))) + (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \$.*\$>") + 1st + 1) + (string-match (format nil "^<1>[ ~%]*\$.*\$") 1st 1) + 1st))) + +(defun split-frame-string (string) + (let ((rx (format nil "~%\$~{~A~^\\|~}\$" + (mapcar #'car *frame-prefixes*)))) + (loop for pos = 0 then (1+ (regexp:match-start match)) + for match = (regexp:match rx string :start pos) + if match collect (subseq string pos (regexp:match-start match)) + else collect (subseq string pos) + while match))) + +(defun string-match (pattern string n) + (let* ((match (nth-value n (regexp:match pattern string)))) + (if match (regexp:match-string string match)))) + +(defimplementation format-sldb-condition (condition) + (trim-whitespace (princ-to-string condition))) + +(defimplementation eval-in-frame (form frame-number) + (sys::eval-at (nth-frame frame-number) form)) + +(defimplementation frame-locals (frame-number) + (let ((frame (nth-frame frame-number))) + (loop for i below (%frame-count-vars frame) + collect (list :name (%frame-var-name frame i) + :value (%frame-var-value frame i) + :id 0)))) + +(defimplementation frame-var-value (frame var) + (%frame-var-value (nth-frame frame) var)) + +;;; Interpreter-Variablen-Environment has the shape +;;; NIL or #(v1 val1 ... vn valn NEXT-ENV). + +(defun %frame-count-vars (frame) + (cond ((sys::eval-frame-p frame) + (do ((venv (frame-venv frame) (next-venv venv)) + (count 0 (+ count (/ (1- (length venv)) 2)))) + ((not venv) count))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (length (%parse-stack-values frame))) + (t 0))) + +(defun %frame-var-name (frame i) + (cond ((sys::eval-frame-p frame) + (nth-value 0 (venv-ref (frame-venv frame) i))) + (t (format nil "~D" i)))) + +(defun %frame-var-value (frame i) + (cond ((sys::eval-frame-p frame) + (let ((name (venv-ref (frame-venv frame) i))) + (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name)) + (if c + (format-sldb-condition c) + v)))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (let ((str (nth i (%parse-stack-values frame)))) + (trim-whitespace (subseq str 2)))) + (t (break "Not implemented")))) + +(defun frame-venv (frame) + (let ((env (sys::eval-at frame '(sys::the-environment)))) + (svref env 0))) + +(defun next-venv (venv) (svref venv (1- (length venv)))) + +(defun venv-ref (env i) + "Reference the Ith binding in ENV. +Return two values: NAME and VALUE" + (let ((idx (* i 2))) + (if (< idx (1- (length env))) + (values (svref env idx) (svref env (1+ idx))) + (venv-ref (next-venv env) (- i (/ (1- (length env)) 2)))))) + +(defun %parse-stack-values (frame) + (labels ((next (fp) (sys::frame-down-1 fp 1)) + (parse (fp accu) + (let ((str (frame-to-string fp))) + (cond ((is-prefix-p "- " str) + (parse (next fp) (cons str accu))) + ((is-prefix-p "<1> " str) + ;;(when (eq (frame-type frame) 'compiled-fun) + ;; (pop accu)) + (dolist (str (cdr (split-frame-string str))) + (when (is-prefix-p "- " str) + (push str accu))) + (nreverse accu)) + (t (parse (next fp) accu)))))) + (parse (next frame) '()))) + +(defun is-prefix-p (pattern string) + (not (mismatch pattern string :end2 (min (length pattern) + (length string))))) + +(defimplementation frame-catch-tags (index) + (declare (ignore index)) + nil) + +(defimplementation return-from-frame (index form) + (sys::return-from-eval-frame (nth-frame index) form)) + +(defimplementation restart-frame (index) + (sys::redo-eval-frame (nth-frame index))) + +(defimplementation frame-source-location-for-emacs (index) + `(:error + ,(format nil "frame-source-location not implemented. (frame: ~A)" + (nth-frame index)))) + +;;;; Profiling + +(defimplementation profile (fname) + (eval `(mon:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + mon:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (mon:unmonitor)) + +(defimplementation profile-report () + (mon:report-monitoring)) + +(defimplementation profile-reset () + (mon:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (mon:monitor-all package)) + +;;;; Handle compiler conditions (find out location of error etc.) + +(defmacro compile-file-frobbing-notes ((&rest args) &body body) + "Pass ARGS to COMPILE-FILE, send the compiler notes to +*STANDARD-INPUT* and frob them in BODY." + `(let ((*error-output* (make-string-output-stream)) + (*compile-verbose* t)) + (multiple-value-prog1 + (compile-file ,@args) + (handler-case + (with-input-from-string + (*standard-input* (get-output-stream-string *error-output*)) + ,@body) + (sys::simple-end-of-file () nil))))) + +(defvar *orig-c-warn* (symbol-function 'system::c-warn)) +(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn)) +(defvar *orig-c-error* (symbol-function 'system::c-error)) +(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems)) + +(defmacro dynamic-flet (names-functions &body body) + "(dynamic-flet ((NAME FUNCTION) ...) BODY ...) +Execute BODY with NAME's function slot set to FUNCTION." + `(ext:letf* ,(loop for (name function) in names-functions + collect `((symbol-function ',name) ,function)) + ,@body)) + +(defvar *buffer-name* nil) +(defvar *buffer-offset*) + +(defun compiler-note-location () + "Return the current compiler location." + (let ((lineno1 sys::*compile-file-lineno1*) + (lineno2 sys::*compile-file-lineno2*) + (file sys::*compile-file-truename*)) + (cond ((and file lineno1 lineno2) + (make-location (list ':file (namestring file)) + (list ':line lineno1))) + (*buffer-name* + (make-location (list ':buffer *buffer-name*) + (list ':position *buffer-offset*))) + (t + (list :error "No error location available"))))) + +(defun signal-compiler-warning (cstring args severity orig-fn) + (signal (make-condition 'compiler-condition + :severity severity + :message (apply #'format nil cstring args) + :location (compiler-note-location))) + (apply orig-fn cstring args)) + +(defun c-warn (cstring &rest args) + (signal-compiler-warning cstring args :warning *orig-c-warn*)) + +(defun c-style-warn (cstring &rest args) + (dynamic-flet ((sys::c-warn *orig-c-warn*)) + (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*))) + +(defun c-error (cstring &rest args) + (signal-compiler-warning cstring args :error *orig-c-error*)) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-notification-condition)) + (dynamic-flet ((system::c-warn #'c-warn) + (system::c-style-warn #'c-style-warn) + (system::c-error #'c-error)) + (funcall function)))) + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (signal (make-condition 'compiler-condition + :original-condition condition + :severity :warning + :message (princ-to-string condition) + :location (compiler-note-location)))) + +(defimplementation swank-compile-file (filename load-p external-format) + (with-compilation-hooks () + (with-compilation-unit () + (let ((fasl-file (compile-file filename + :external-format external-format))) + (when (and load-p fasl-file) + (load fasl-file)) + nil)))) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-offset* position)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string))))))) + +;;;; Portable XREF from the CMU AI repository. + +(setq pxref::*handle-package-forms* '(cl:in-package)) + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls pxref:list-callers) +(defxref who-references pxref:list-readers) +(defxref who-binds pxref:list-setters) +(defxref who-sets pxref:list-setters) +(defxref list-callers pxref:list-callers) +(defxref list-callees pxref:list-callees) + +(defun xref-results (symbols) + (let ((xrefs '())) + (dolist (symbol symbols) + (push (list symbol (fspec-location symbol)) xrefs)) + xrefs)) + +(when (find-package :swank-loader) + (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader)) + (lambda () + (let ((home (user-homedir-pathname))) + (and (ext:probe-directory home) + (probe-file (format nil "~A/.swank.lisp" + (namestring (truename home))))))))) + +;;; Don't set *debugger-hook* to nil on break. +(ext:without-package-lock () + (defun break (&optional (format-string "Break") &rest args) + (if (not sys::*use-clcs*) + (progn + (terpri *error-output*) + (apply #'format *error-output* + (concatenate 'string "*** - " format-string) + args) + (funcall ext:*break-driver* t)) + (let ((condition + (make-condition 'simple-condition + :format-control format-string + :format-arguments args)) + ;;(*debugger-hook* nil) + ;; Issue 91 + ) + (ext:with-restarts + ((continue + :report (lambda (stream) + (format stream (sys::text "Return from ~S loop") + 'break)) + ())) + (with-condition-restarts condition (list (find-restart 'continue)) + (invoke-debugger condition))))) + nil)) + +;;;; Inspecting + +(defclass clisp-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () (make-instance 'clisp-inspector)) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (declare (ignore inspector)) + (let* ((*print-array* nil) (*print-pretty* t) + (*print-circle* t) (*print-escape* t) + (*print-lines* custom:*inspect-print-lines*) + (*print-level* custom:*inspect-print-level*) + (*print-length* custom:*inspect-print-length*) + (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t)) + (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-"))) + (*package* tmp-pack) + (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack))) + (let ((inspection (sys::inspect-backend o))) + (values (format nil "~S~% ~A~{~%~A~}" o + (sys::insp-title inspection) + (sys::insp-blurb inspection)) + (loop with count = (sys::insp-num-slots inspection) + for i below count + append (multiple-value-bind (value name) + (funcall (sys::insp-nth-slot inspection) + i) + `((:value ,name) " = " (:value ,value) + (:newline)))))))) + +(defimplementation quit-lisp () + #+lisp=cl (ext:quit) + #-lisp=cl (lisp:quit)) + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +;;; Local Variables: +;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1) +;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1) +;;; End: Added: branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,2255 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; License: Public Domain +;;; +;;;; Introduction +;;; +;;; This is the CMUCL implementation of the `swank-backend' package. + +(in-package :swank-backend) + +(import-swank-mop-symbols :pcl '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + +;;;; "Hot fixes" +;;; +;;; Here are necessary bugfixes to the oldest supported version of +;;; CMUCL (currently 18e). Any fixes placed here should also be +;;; submitted to the `cmucl-imp' mailing list and confirmed as +;;; good. When a new release is made that includes the fixes we should +;;; promptly delete them from here. It is enough to be compatible with +;;; the latest release. + +(in-package :lisp) + +;;; `READ-SEQUENCE' with large sequences has problems in 18e. This new +;;; definition works better. + +#-cmu19 +(progn + (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp))) + (when s + (setf (symbol-value s) nil))) + + (defun read-into-simple-string (s stream start end) + (declare (type simple-string s)) + (declare (type stream stream)) + (declare (type index start end)) + (unless (subtypep (stream-element-type stream) 'character) + (error 'type-error + :datum (read-char stream nil #\Null) + :expected-type (stream-element-type stream) + :format-control "Trying to read characters from a binary stream.")) + ;; Let's go as low level as it seems reasonable. + (let* ((numbytes (- end start)) + (total-bytes 0)) + ;; read-n-bytes may return fewer bytes than requested, so we need + ;; to keep trying. + (loop while (plusp numbytes) do + (let ((bytes-read (system:read-n-bytes stream s start numbytes nil))) + (when (zerop bytes-read) + (return-from read-into-simple-string total-bytes)) + (incf total-bytes bytes-read) + (incf start bytes-read) + (decf numbytes bytes-read))) + total-bytes)) + + (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp))) + (when s + (setf (symbol-value s) t))) + + ) + +(in-package :swank-backend) + + +;;;; TCP server +;;; +;;; In CMUCL we support all communication styles. By default we use +;;; `:SIGIO' because it is the most responsive, but it's somewhat +;;; dangerous: CMUCL is not in general "signal safe", and you don't +;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and +;;; `:SPAWN' are reasonable alternatives. + +(defimplementation preferred-communication-style () + :sigio) + +#-(or darwin mips) +(defimplementation create-socket (host port) + (let* ((addr (resolve-hostname host)) + (addr (if (not (find-symbol "SOCKET-ERROR" :ext)) + (ext:htonl addr) + addr))) + (ext:create-inet-listener port :stream :reuse-address t :host addr))) + +;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix. +#+(or darwin mips) +(defimplementation create-socket (host port) + (declare (ignore host)) + (ext:create-inet-listener port :stream :reuse-address t)) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (let ((fd (socket-fd socket))) + (sys:invalidate-descriptor fd) + (ext:close-socket fd))) + +(defimplementation accept-connection (socket &key + external-format buffering timeout) + (declare (ignore timeout external-format)) + (let ((buffering (or buffering :full))) + (make-socket-io-stream (ext:accept-tcp-connection socket) buffering))) + +;;;;; Sockets + +(defun socket-fd (socket) + "Return the filedescriptor for the socket represented by SOCKET." + (etypecase socket + (fixnum socket) + (sys:fd-stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of HOSTNAME as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(defun make-socket-io-stream (fd buffering) + "Create a new input/output fd-stream for FD." + (sys:make-fd-stream fd :input t :output t :element-type 'base-char + :buffering buffering)) + +;;;;; Signal-driven I/O + +(defvar *sigio-handlers* '() + "List of (key . function) pairs. +All functions are called on SIGIO, and the key is used for removing +specific functions.") + +(defun set-sigio-handler () + (sys:enable-interrupt :sigio (lambda (signal code scp) + (sigio-handler signal code scp)))) + +(defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (mapc #'funcall (mapcar #'cdr *sigio-handlers*))) + +(defun fcntl (fd command arg) + "fcntl(2) - manipulate a file descriptor." + (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg) + (unless ok (error "fcntl: ~A" (unix:get-unix-error-msg error))))) + +(defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (fcntl fd unix:f-setown (unix:unix-getpid)) + (fcntl fd unix:f-setfl unix:fasync) + (push (cons fd fn) *sigio-handlers*))) + +(defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car)) + (sys:invalidate-descriptor fd))) + +;;;;; SERVE-EVENT + +(defimplementation add-fd-handler (socket fn) + (let ((fd (socket-fd socket))) + (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn))))) + +(defimplementation remove-fd-handlers (socket) + (sys:invalidate-descriptor (socket-fd socket))) + + +;;;; Stream handling +;;; XXX: How come we don't use Gray streams in CMUCL too? -luke (15/May/2004) + +(defimplementation make-fn-streams (input-fn output-fn) + (let* ((output (make-slime-output-stream output-fn)) + (input (make-slime-input-stream input-fn output))) + (values input output))) + +(defstruct (slime-output-stream + (:include lisp::lisp-stream + (lisp::misc #'sos/misc) + (lisp::out #'sos/out) + (lisp::sout #'sos/sout)) + (:conc-name sos.) + (:print-function %print-slime-output-stream) + (:constructor make-slime-output-stream (output-fn))) + (output-fn nil :type function) + (buffer (make-string 8000) :type string) + (index 0 :type kernel:index) + (column 0 :type kernel:index) + (last-flush-time (get-internal-real-time) :type unsigned-byte)) + +(defun %print-slime-output-stream (s stream d) + (declare (ignore d)) + (print-unreadable-object (s stream :type t :identity t))) + +(defun sos/out (stream char) + (system:without-interrupts + (let ((buffer (sos.buffer stream)) + (index (sos.index stream))) + (setf (schar buffer index) char) + (setf (sos.index stream) (1+ index)) + (incf (sos.column stream)) + (when (char= #\newline char) + (setf (sos.column stream) 0) + (force-output stream)) + (when (= index (1- (length buffer))) + (finish-output stream))) + char)) + +(defun sos/sout (stream string start end) + (system:without-interrupts + (loop for i from start below end + do (sos/out stream (aref string i))))) + +(defun log-stream-op (stream operation) + stream operation + #+(or) + (progn + (format sys:*tty* "~S @ ~D ~A~%" operation + (sos.index stream) + (/ (- (get-internal-real-time) (sos.last-flush-time stream)) + (coerce internal-time-units-per-second 'double-float))) + (finish-output sys:*tty*))) + +(defun sos/misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case operation + (:finish-output + (log-stream-op stream operation) + (system:without-interrupts + (let ((end (sos.index stream))) + (unless (zerop end) + (let ((s (subseq (sos.buffer stream) 0 end))) + (setf (sos.index stream) 0) + (funcall (sos.output-fn stream) s)) + (setf (sos.last-flush-time stream) (get-internal-real-time))))) + nil) + (:force-output + (log-stream-op stream operation) + (sos/misc-force-output stream) + nil) + (:charpos (sos.column stream)) + (:line-length 75) + (:file-position nil) + (:element-type 'base-char) + (:get-command nil) + (:close nil) + (t (format *terminal-io* "~&~Astream: ~S~%" stream operation)))) + +(defun sos/misc-force-output (stream) + (system:without-interrupts + (unless (or (zerop (sos.index stream)) + (loop with buffer = (sos.buffer stream) + for i from 0 below (sos.index stream) + always (char= (aref buffer i) #\newline))) + (let ((last (sos.last-flush-time stream)) + (now (get-internal-real-time))) + (when (> (/ (- now last) + (coerce internal-time-units-per-second 'double-float)) + 0.1) + (finish-output stream)))))) + +(defstruct (slime-input-stream + (:include string-stream + (lisp::in #'sis/in) + (lisp::misc #'sis/misc)) + (:conc-name sis.) + (:print-function %print-slime-output-stream) + (:constructor make-slime-input-stream (input-fn sos))) + (input-fn nil :type function) + ;; We know our sibling output stream, so that we can force it before + ;; requesting input. + (sos nil :type slime-output-stream) + (buffer "" :type string) + (index 0 :type kernel:index)) + +(defun sis/in (stream eof-errorp eof-value) + (finish-output (sis.sos stream)) + (let ((index (sis.index stream)) + (buffer (sis.buffer stream))) + (when (= index (length buffer)) + (let ((string (funcall (sis.input-fn stream)))) + (cond ((zerop (length string)) + (return-from sis/in + (if eof-errorp + (error (make-condition 'end-of-file :stream stream)) + eof-value))) + (t + (setf buffer string) + (setf (sis.buffer stream) buffer) + (setf index 0))))) + (prog1 (aref buffer index) + (setf (sis.index stream) (1+ index))))) + +(defun sis/misc (stream operation &optional arg1 arg2) + (declare (ignore arg2)) + (ecase operation + (:file-position nil) + (:file-length nil) + (:unread (setf (aref (sis.buffer stream) + (decf (sis.index stream))) + arg1)) + (:clear-input + (setf (sis.index stream) 0 + (sis.buffer stream) "")) + (:listen (< (sis.index stream) (length (sis.buffer stream)))) + (:charpos nil) + (:line-length nil) + (:get-command nil) + (:element-type 'base-char) + (:close nil) + (:interactive-p t))) + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. +NIL if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation swank-compile-file (filename load-p external-format) + (declare (ignore external-format)) + (clear-xref-info filename) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (ext:*ignore-extra-close-parentheses* nil)) + (multiple-value-bind (output-file warnings-p failure-p) + (compile-file filename) + (unless failure-p + ;; Cache the latest source file for definition-finding. + (source-cache-get filename (file-write-date filename)) + (when load-p (load output-file))) + (values output-file warnings-p failure-p))))) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string)) + (with-input-from-string (stream string) + (ext:compile-from-stream + stream + :source-info `(:emacs-buffer ,buffer + :emacs-buffer-offset ,position + :emacs-buffer-string ,string)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `SWANK:COMPILER-CONDITION's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal (make-condition + 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :short-message (brief-compiler-message-for-emacs condition) + :message (long-compiler-message-for-emacs condition context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context))))) + +(defun severity-for-emacs (condition) + "Return the severity of CONDITION." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (princ-to-string condition)) + +(defun long-compiler-message-for-emacs (condition error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A" + enclosing source condition))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :position (+ *buffer-start-position* pos)))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. +Return a `location' record, or (:error REASON) on failure." + (if (null context) + (note-error-location) + (let ((file (c::compiler-error-context-file-name context)) + (source (c::compiler-error-context-original-source context)) + (path + (reverse (c::compiler-error-context-original-source-path context)))) + (or (locate-compiler-note file source path) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (list :error "No error location available.")) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (let ((position (+ *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + (make-location (list :buffer *buffer-name*) + (list :position position)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position + (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + +;;;; XREF +;;; +;;; Cross-reference support is based on the standard CMUCL `XREF' +;;; package. This package has some caveats: XREF information is +;;; recorded during compilation and not preserved in fasl files, and +;;; XREF recording is disabled by default. Redefining functions can +;;; also cause duplicate references to accumulate, but +;;; `swank-compile-file' will automatically clear out any old records +;;; from the same filename. +;;; +;;; To enable XREF recording, set `c:*record-xref-info*' to true. To +;;; clear out the XREF database call `xref:init-xref-database'. + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls xref:who-calls) +(defxref who-references xref:who-references) +(defxref who-binds xref:who-binds) +(defxref who-sets xref:who-sets) + +;;; More types of XREF information were added since 18e: +;;; +#+cmu19 +(progn + (defxref who-macroexpands xref:who-macroexpands) + ;; XXX + (defimplementation who-specializes (symbol) + (let* ((methods (xref::who-specializes (find-class symbol))) + (locations (mapcar #'method-location methods))) + (mapcar #'list methods locations)))) + +(defun xref-results (contexts) + (mapcar (lambda (xref) + (list (xref:xref-context-name xref) + (resolve-xref-location xref))) + contexts)) + +(defun resolve-xref-location (xref) + (let ((name (xref:xref-context-name xref)) + (file (xref:xref-context-file xref)) + (source-path (xref:xref-context-source-path xref))) + (cond ((and file source-path) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (unix-truename file)) + (list :position (1+ position))))) + (file + (make-location (list :file (unix-truename file)) + (list :function-name (string name)))) + (t + `(:error ,(format nil "Unknown source location: ~S ~S ~S " + name file source-path)))))) + +(defun clear-xref-info (namestring) + "Clear XREF notes pertaining to NAMESTRING. +This is a workaround for a CMUCL bug: XREF records are cumulative." + (when c:*record-xref-info* + (let ((filename (truename namestring))) + (dolist (db (list xref::*who-calls* + #+cmu19 xref::*who-is-called* + #+cmu19 xref::*who-macroexpands* + xref::*who-references* + xref::*who-binds* + xref::*who-sets*)) + (maphash (lambda (target contexts) + ;; XXX update during traversal? + (setf (gethash target db) + (delete filename contexts + :key #'xref:xref-context-file + :test #'equalp))) + db))))) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(declaim (inline map-code-constants)) +(defun map-code-constants (code fn) + "Call FN for each constant in CODE's constant pool." + (check-type code kernel:code-component) + (loop for i from vm:code-constants-offset below (kernel:get-header-data code) + do (funcall fn (kernel:code-header-ref code i)))) + +(defun function-callees (function) + "Return FUNCTION's callees as a list of functions." + (let ((callees '())) + (map-code-constants + (vm::find-code-object function) + (lambda (obj) + (when (kernel:fdefn-p obj) + (push (kernel:fdefn-function obj) callees)))) + callees)) + +(declaim (ext:maybe-inline map-allocated-code-components)) +(defun map-allocated-code-components (spaces fn) + "Call FN for each allocated code component in one of SPACES. FN +receives the object as argument. SPACES should be a list of the +symbols :dynamic, :static, or :read-only." + (dolist (space spaces) + (declare (inline vm::map-allocated-objects) + (optimize (ext:inhibit-warnings 3))) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum size) (ignore size)) + (when (= vm:code-header-type header) + (funcall fn obj))) + space))) + +(declaim (ext:maybe-inline map-caller-code-components)) +(defun map-caller-code-components (function spaces fn) + "Call FN for each code component with a fdefn for FUNCTION in its +constant pool." + (let ((function (coerce function 'function))) + (declare (inline map-allocated-code-components)) + (map-allocated-code-components + spaces + (lambda (obj) + (map-code-constants + obj + (lambda (constant) + (when (and (kernel:fdefn-p constant) + (eq (kernel:fdefn-function constant) + function)) + (funcall fn obj)))))))) + +(defun function-callers (function &optional (spaces '(:read-only :static + :dynamic))) + "Return FUNCTION's callers. The result is a list of code-objects." + (let ((referrers '())) + (declare (inline map-caller-code-components)) + ;;(ext:gc :full t) + (map-caller-code-components function spaces + (lambda (code) (push code referrers))) + referrers)) + +(defun debug-info-definitions (debug-info) + "Return the defintions for a debug-info. This should only be used +for code-object without entry points, i.e., byte compiled +code (are theree others?)" + ;; This mess has only been tested with #'ext::skip-whitespace, a + ;; byte-compiled caller of #'read-char . + (check-type debug-info (and (not c::compiled-debug-info) c::debug-info)) + (let ((name (c::debug-info-name debug-info)) + (source (c::debug-info-source debug-info))) + (destructuring-bind (first) source + (ecase (c::debug-source-from first) + (:file + (list (list name + (make-location + (list :file (unix-truename (c::debug-source-name first))) + (list :function-name (string name)))))))))) + +(defun code-component-entry-points (code) + "Return a list ((NAME LOCATION) ...) of function definitons for +the code omponent CODE." + (let ((names '())) + (do ((f (kernel:%code-entry-points code) (kernel::%function-next f))) + ((not f)) + (let ((name (kernel:%function-name f))) + (when (ext:valid-function-name-p name) + (push (list name (function-location f)) names)))) + names)) + +(defimplementation list-callers (symbol) + "Return a list ((NAME LOCATION) ...) of callers." + (let ((components (function-callers symbol)) + (xrefs '())) + (dolist (code components) + (let* ((entry (kernel:%code-entry-points code)) + (defs (if entry + (code-component-entry-points code) + ;; byte compiled stuff + (debug-info-definitions + (kernel:%code-debug-info code))))) + (setq xrefs (nconc defs xrefs)))) + xrefs)) + +(defimplementation list-callees (symbol) + (let ((fns (function-callees symbol))) + (mapcar (lambda (fn) + (list (kernel:%function-name fn) + (function-location fn))) + fns))) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the CMUCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `swank-source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. +This is useful when debugging the definition-finding code.") + +(defvar *source-snippet-size* 256 + "Maximum number of characters in a snippet of source code. +Snippets at the beginning of definitions are used to tell Emacs what +the definitions looks like, so that it can accurately find them by +text search.") + +(defmacro safe-definition-finding (&body body) + "Execute BODY and return the source-location it returns. +If an error occurs and `*debug-definition-finding*' is false, then +return an error pseudo-location. + +The second return value is NIL if no error occurs, otherwise it is the +condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values `(:error ,(trim-whitespace (princ-to-string c))) + c)))))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for CODE-LOCATION." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for CODE-LOCATION in FILENAME." + (let* ((code-date (di:debug-source-created debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a CODE-LOCATION from a stream. +This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLIME stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :position (+ (getf info :emacs-buffer-offset) position)) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for DEBUG-INFO. +Function-name source-locations are a fallback for when precise +positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location? +This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream) + "Return the byte offset of CODE-LOCATION in STREAM. Extract the +toplevel-form-number and form-number from CODE-LOCATION and use that +to find the position of the corresponding form. + +Finish with STREAM positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (di:code-location-top-level-form-offset location)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in STREAM. +TLF-NUMBER is the top-level-form number. +FORM-NUMBER is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of CODE-LOCATION in STRING. +See CODE-LOCATION-STREAM-POSITION." + (with-input-from-string (s string) + (code-location-stream-position code-location s))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name))) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; CMUCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the CMUCL manual for more details. + +(defun function-definitions (name) + "Return definitions for NAME in the \"function namespace\", i.e., +regular functions, generic functions, methods and macros. +NAME can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (special? (and (symbolp name) (special-operator-p name))) + (function? (and (ext:valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (special? + (list `((:special-operator ,name) + (:error ,(format nil "Special operator: ~S" name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (generic-function-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for FUNCTION." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + + +(defun byte-function-location (fn) + "Return the location of the byte-compiled function FN." + (etypecase fn + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((component (c::byte-function-component fn)) + (debug-info (kernel:%code-debug-info component))) + (debug-info-function-name-location debug-info))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fn))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is FUNCTION a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that FUNCTION belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + ;; Find the location in a constructor. + (function-location (struct-constructor dd))) + +(defun struct-constructor (dd) + "Return a constructor function from a defstruct definition. +Signal an error if no constructor can be found." + (let ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (when (or (null constructor) + (and (consp constructor) (null (car constructor)))) + (error "Cannot find structure's constructor: ~S" + (kernel::dd-name dd))) + (coerce (if (consp constructor) (first constructor) constructor) + 'function))) + +;;;;;; Generic functions and methods + +(defun generic-function-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (pcl::generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (pcl::generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable \"definition specifier\" for METHOD." + (let* ((gf (pcl:method-generic-function method)) + (name (pcl:generic-function-name gf)) + (specializers (pcl:method-specializers method)) + (qualifiers (pcl:method-qualifiers method))) + `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers)))) + +;; XXX maybe special case setters/getters +(defun method-location (method) + (function-location (or (pcl::method-fast-function method) + (pcl:method-function method)))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (kernel::find-class name nil))) + (etypecase class + (null '()) + (kernel::structure-class + (list (list `(defstruct ,name) (dd-location (find-dd name))))) + #+(or) + (conditions::condition-class + (list (list `(define-condition ,name) + (condition-class-location class)))) + (kernel::standard-class + (list (list `(defclass ,name) + (class-location (find-class name))))) + ((or kernel::built-in-class + conditions::condition-class + kernel:funcallable-structure-class) + (list (list `(kernel::define-type-class ,name) + `(:error + ,(format nil "No source info for ~A" name))))))))) + +(defun class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (pcl:class-name class))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((slots (conditions::condition-class-slots class)) + (name (conditions::condition-class-name class))) + (cond ((null slots) + `(:error ,(format nil "No location info for condition: ~A" name))) + (t + ;; Find the class via one of its slot-reader methods. + (let* ((slot (first slots)) + (gf (fdefinition + (first (conditions::condition-slot-readers slot))))) + (method-location + (first + (pcl:compute-applicable-methods-using-classes + gf (list (find-class name)))))))))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun source-location-form-numbers (location) + (c::decode-form-numbers (c::form-numbers-form-numbers location))) + +(defun source-location-tlf-number (location) + (nth-value 0 (source-location-form-numbers location))) + +(defun source-location-form-number (location) + (nth-value 1 (source-location-form-numbers location))) + +(defun resolve-file-source-location (location) + (let ((filename (c::file-source-location-pathname location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + (with-open-file (s filename) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:file ,(unix-truename filename)) + `(:position ,(1+ pos))))))) + +(defun resolve-stream-source-location (location) + (let ((info (c::stream-source-location-user-info location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + ;; XXX duplication in frame-source-location + (assert (info-from-emacs-buffer-p info)) + (destructuring-bind (&key emacs-buffer emacs-buffer-string + emacs-buffer-offset) info + (with-input-from-string (s emacs-buffer-string) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:buffer ,emacs-buffer) + `(:position ,(+ emacs-buffer-offset pos)))))))) + +;; XXX predicates for 18e backward compatibilty. Remove them when +;; we're 19a only. +(defun file-source-location-p (object) + (when (fboundp 'c::file-source-location-p) + (c::file-source-location-p object))) + +(defun stream-source-location-p (object) + (when (fboundp 'c::stream-source-location-p) + (c::stream-source-location-p object))) + +(defun source-location-p (object) + (or (file-source-location-p object) + (stream-source-location-p object))) + +(defun resolve-source-location (location) + (etypecase location + ((satisfies file-source-location-p) + (resolve-file-source-location location)) + ((satisfies stream-source-location-p) + (resolve-stream-source-location location)))) + +(defun definition-source-location (object name) + (let ((source (pcl::definition-source object))) + (etypecase source + (null + `(:error ,(format nil "No source info for: ~A" object))) + ((satisfies source-location-p) + (resolve-source-location source)) + (pathname + (make-name-in-file-location source name)) + (cons + (destructuring-bind ((dg name) pathname) source + (declare (ignore dg)) + (etypecase pathname + (pathname (make-name-in-file-location pathname (string name))) + (null `(:error ,(format nil "Cannot resolve: ~S" source))))))))) + +(defun setf-definitions (name) + (let ((function (or (ext:info :setf :inverse name) + (ext:info :setf :expander name) + (and (symbolp name) + (fboundp `(setf ,name)) + (fdefinition `(setf ,name)))))) + (if function + (list (list `(setf ,name) + (function-location (coerce function 'function))))))) + + +(defun variable-location (symbol) + (multiple-value-bind (location foundp) + ;; XXX for 18e compatibilty. rewrite this when we drop 18e + ;; support. + (ignore-errors (eval `(ext:info :source-location :defvar ',symbol))) + (if (and foundp location) + (resolve-source-location location) + `(:error ,(format nil "No source info for variable ~S" symbol))))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(c::vop ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unkown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (etypecase fun + (function (function-arglist fun)) + (symbol (function-arglist (or (macro-function fun) + (symbol-function fun)))))) + +(defun function-arglist (fun) + (let ((arglist + (cond ((eval:interpreted-function-p fun) + (eval:interpreted-function-arglist fun)) + ((pcl::generic-function-p fun) + (pcl:generic-function-lambda-list fun)) + ((c::byte-function-or-closure-p fun) + (byte-code-function-arglist fun)) + ((kernel:%function-arglist (kernel:%function-self fun)) + (handler-case (read-arglist fun) + (error () :not-available))) + ;; this should work both for compiled-debug-function + ;; and for interpreted-debug-function + (t + (handler-case (debug-function-arglist + (di::function-debug-function fun)) + (di:unhandled-condition () :not-available)))))) + (check-type arglist (or list (member :not-available))) + arglist)) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((pcl::generic-function-p function) + (pcl::generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + +;;; A simple case: the arglist is available as a string that we can +;;; `read'. + +(defun read-arglist (fn) + "Parse the arglist-string of the function object FN." + (let ((string (kernel:%function-arglist + (kernel:%function-self fn))) + (package (find-package + (c::compiled-debug-info-package + (kernel:%code-debug-info + (vm::find-code-object fn)))))) + (with-standard-io-syntax + (let ((*package* (or package *package*))) + (read-from-string string))))) + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. +A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + +;;; Deriving arglists for byte-compiled functions: +;;; +(defun byte-code-function-arglist (fn) + ;; There doesn't seem to be much arglist information around for + ;; byte-code functions. Use the arg-count and return something like + ;; (arg0 arg1 ...) + (etypecase fn + (c::simple-byte-function + (loop for i from 0 below (c::simple-byte-function-num-args fn) + collect (make-arg-symbol i))) + (c::hairy-byte-function + (hairy-byte-function-arglist fn)) + (c::byte-closure + (byte-code-function-arglist (c::byte-closure-function fn))))) + +(defun make-arg-symbol (i) + (make-symbol (format nil "~A~D" (string 'arg) i))) + +;;; A "hairy" byte-function is one that takes a variable number of +;;; arguments. `hairy-byte-function' is a type from the bytecode +;;; interpreter. +;;; +(defun hairy-byte-function-arglist (fn) + (let ((counter -1)) + (flet ((next-arg () (make-arg-symbol (incf counter)))) + (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p + keywords-p keywords) fn + (let ((arglist '()) + (optional (- max-args min-args))) + ;; XXX isn't there a better way to write this? + ;; (Looks fine to me. -luke) + (dotimes (i min-args) + (push (next-arg) arglist)) + (when (plusp optional) + (push '&optional arglist) + (dotimes (i optional) + (push (next-arg) arglist))) + (when rest-arg-p + (push '&rest arglist) + (push (next-arg) arglist)) + (when keywords-p + (push '&key arglist) + (loop for (key _ __) in keywords + do (push key arglist)) + (when (eq keywords-p :allow-others) + (push '&allow-other-keys arglist))) + (nreverse arglist)))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form) + (walker:macroexpand-all form)) + +(defimplementation compiler-macroexpand-1 (form &optional env) + (ext:compiler-macroexpand-1 form env)) + +(defimplementation compiler-macroexpand (form &optional env) + (ext:compiler-macroexpand form env)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation call-without-interrupts (fn) + (sys:without-interrupts (funcall fn))) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + "cmucl") + +(defimplementation quit-lisp () + (ext::quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; swank-source-path-parser + + +;;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (unix:unix-sigsetmask 0) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error (make-condition + 'sldb-condition + :original-condition condition))))) + (unwind-protect + (progn + #+(or)(sys:scrub-control-stack) + (funcall debugger-loop-fn)) + #+(or)(sys:scrub-control-stack) + )))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (frame-down f) + for i from start below end + while f + collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location-for-emacs (index) + (code-location-source-location (di:frame-code-location (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (di::debug-function-debug-variables (di:frame-debug-function frame))) + +(defun debug-var-value (var frame location) + (let ((validity (di:debug-variable-validity var location))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (di:frame-code-location frame)) + (vars (frame-debug-vars frame))) + (loop for v across vars collect + (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame loc))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame (di:frame-code-location frame)))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (string 'find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of CMUCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sldb-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +;; XXX don't break old versions without fwrappers. Remove this one day. +#+#.(cl:if (cl:find-package :fwrappers) '(and) '(or)) +(progn + (fwrappers:define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext) + (let ((*breakpoint-sigcontext* sigcontext) + (*breakpoint-pc* offset)) + (fwrappers:call-next-function))) + (fwrappers:set-fwrappers 'di::handle-breakpoint '()) + (fwrappers:fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext)) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:sigcontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:sigcontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; CMUCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<<known-return convention not supported>>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in +;; newer versions of CMUCL (after ~March 2005). +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di))) + (cond (sym (funcall sym sigcontext)) + (t (di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +(defimplementation condition-extras (condition) + (typecase condition + (breakpoint + ;; pop up the source buffer + `((:show-frame-source 0))) + (t '()))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +(defimplementation sldb-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + ((or di::bogus-debug-function di::interpreted-debug-function) + -1))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +CSP = ~X +CFP = ~X +IP = ~X +OCFP = ~X +LRA = ~X~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + + +(defimplementation disassemble-frame (frame-number) + "Return a string with the disassembly of frames code." + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (format t "~%[Disassembling bogus frames not implemented]"))))) + + +;;;; Inspecting + +(defclass cmucl-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'cmucl-inspector)) + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:instance-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp "-TYPE" (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list "-TYPE" "VM") + (apropos-list "-TYPE" "BIGNUM")))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (cond ((di::indirect-value-cell-p o) + (values (format nil "~A is a value cell." o) + `("Value: " (:value ,(c:value-cell-ref o))))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (cmucl-inspect o)))) + +(defun cmucl-inspect (o) + (destructuring-bind (text labeledp . parts) (inspect::describe-parts o) + (values (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) + (declare (ignore inspector)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (values (format nil "~A is a function." o) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s)))))) + ((= header vm:closure-header-type) + (values (format nil "~A is a closure" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (1- (kernel:get-closure-length o)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (cmucl-inspect o)) + (t + (call-next-method))))) + +(defmethod inspect-for-emacs ((o kernel:funcallable-instance) + (i backend-inspector)) + (declare (ignore i)) + (values + (format nil "~A is a funcallable-instance." o) + (append (label-value-line* + (:function (kernel:%funcallable-instance-function o)) + (:lexenv (kernel:%funcallable-instance-lexenv o)) + (:layout (kernel:%funcallable-instance-layout o))) + (nth-value 1 (cmucl-inspect o))))) + +(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector)) + (declare (ignore _)) + (values (format nil "~A is a code data-block." o) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" (:newline) + , (with-output-to-string (s) + (cond ((kernel:%code-debug-info o) + (disassem:disassemble-code-component o :stream s)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift) + :stream s)))))))) + +(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector)) + (declare (ignore inspector)) + (values (format nil "~A is a fdenf object." o) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) + +(defmethod inspect-for-emacs ((o array) (inspector backend-inspector)) + inspector + (if (typep o 'simple-array) + (call-next-method) + (values (format nil "~A is an array." o) + (label-value-line* + (:header (describe-primitive-type o)) + (:rank (array-rank o)) + (:fill-pointer (kernel:%array-fill-pointer o)) + (:fill-pointer-p (kernel:%array-fill-pointer-p o)) + (:elements (kernel:%array-available-elements o)) + (:data (kernel:%array-data-vector o)) + (:displacement (kernel:%array-displacement o)) + (:displaced-p (kernel:%array-displaced-p o)) + (:dimensions (array-dimensions o)))))) + +(defmethod inspect-for-emacs ((o simple-vector) (inspector backend-inspector)) + inspector + (values (format nil "~A is a simple-vector." o) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (loop for i below (length o) + append (label-value-line i (aref o i)))))) + +(defun inspect-alien-record (alien) + (values + (format nil "~A is an alien value." alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (label-value-line slot (alien:slot alien slot))))))))) + +(defun inspect-alien-pointer (alien) + (values + (format nil "~A is an alien value." alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien)))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (cmucl-inspect alien)))) + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + #-cmu18e :methods #-cmu18e methods)) + + +;;;; Multiprocessing + +#+mp +(progn + (defimplementation initialize-multiprocessing (continuation) + (mp::init-multi-processing) + (mp:make-process continuation :name "swank") + ;; Threads magic: this never returns! But top-level becomes + ;; available again. + (unless mp::*idle-process* + (mp::startup-idle-and-top-level-loops))) + + (defimplementation spawn (fn &key name) + (mp:make-process fn :name (or name "Anonymous"))) + + (defvar *thread-id-counter* 0) + + (defimplementation thread-id (thread) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*)))) + + (defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (mp:process-whostate thread)) + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (copy-list mp:*all-processes*)) + + (defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + + (defimplementation kill-thread (thread) + (mp:destroy-process thread)) + + (defvar *mailbox-lock* (mp:make-lock "mailbox lock")) + + (defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock "process mailbox")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock-held (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (mp:with-lock-held (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + + (defimplementation receive () + (let* ((mbox (mailbox mp:*current-process*)) + (mutex (mailbox.mutex mbox))) + (mp:process-wait "receive" #'mailbox.queue mbox) + (mp:with-lock-held (mutex) + (pop (mailbox.queue mbox))))) + + ) ;; #+mp + + + +;;;; GC hooks +;;; +;;; Display GC messages in the echo area to avoid cluttering the +;;; normal output. +;;; + +;; this should probably not be here, but where else? +(defun background-message (message) + (funcall (find-symbol (string :background-message) :swank) + message)) + +(defun print-bytes (nbytes &optional stream) + "Print the number NBYTES to STREAM in KB, MB, or GB units." + (let ((names '((0 bytes) (10 kb) (20 mb) (30 gb) (40 tb) (50 eb)))) + (multiple-value-bind (power name) + (loop for ((p1 n1) (p2 n2)) on names + while n2 do + (when (<= (expt 2 p1) nbytes (1- (expt 2 p2))) + (return (values p1 n1)))) + (cond (name + (format stream "~,1F ~A" (/ nbytes (expt 2 power)) name)) + (t + (format stream "~:D bytes" nbytes)))))) + +(defconstant gc-generations 6) + +#+gencgc +(defun generation-stats () + "Return a string describing the size distribution among the generations." + (let* ((alloc (loop for i below gc-generations + collect (lisp::gencgc-stats i))) + (sum (coerce (reduce #'+ alloc) 'float))) + (format nil "~{~3F~^/~}" + (mapcar (lambda (size) (/ size sum)) + alloc)))) + +(defvar *gc-start-time* 0) + +(defun pre-gc-hook (bytes-in-use) + (setq *gc-start-time* (get-internal-real-time)) + (let ((msg (format nil "[Commencing GC with ~A in use.]" + (print-bytes bytes-in-use)))) + (background-message msg))) + +(defun post-gc-hook (bytes-retained bytes-freed trigger) + (declare (ignore trigger)) + (let* ((seconds (/ (- (get-internal-real-time) *gc-start-time*) + internal-time-units-per-second)) + (msg (format nil "[GC done. ~A freed ~A retained ~A ~4F sec]" + (print-bytes bytes-freed) + (print-bytes bytes-retained) + #+gencgc(generation-stats) + #-gencgc"" + seconds))) + (background-message msg))) + +(defun install-gc-hooks () + (setq ext:*gc-notify-before* #'pre-gc-hook) + (setq ext:*gc-notify-after* #'post-gc-hook)) + +(defun remove-gc-hooks () + (setq ext:*gc-notify-before* #'lisp::default-gc-notify-before) + (setq ext:*gc-notify-after* #'lisp::default-gc-notify-after)) + +(defvar *install-gc-hooks* t + "If non-nil install GC hooks") + +(defimplementation emacs-connected () + (when *install-gc-hooks* + (install-gc-hooks))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;;In CMUCL, we have: +;; (trace <name>) +;; (trace (method <name> <qualifier>? (<specializer>+))) +;; (trace :methods t '<name>) ;;to trace all methods of the gf <name> +;; <name> can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + (cond ((fboundp `(method ,@(cdr spec))) + (toggle-trace-aux `(method ,(cdr spec)))) + ;; Man, is this ugly + ((fboundp `(pcl::fast-method ,@(cdr spec))) + (toggle-trace-aux `(pcl::fast-method ,@(cdr spec)))) + (t + (error 'undefined-function :name (cdr spec))))) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))) + ;; doesn't work properly + ;; ((:labels :flet) (toggle-trace-aux (process-fspec spec))) + )) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ((:labels) `(labels ,(third fspec) ,(process-fspec (second fspec)))) + ((:flet) `(flet ,(third fspec) ,(process-fspec (second fspec)))))) + (t + fspec))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) + +;; Local Variables: +;; pbook-heading-regexp: "^;;;\$;+\$" +;; pbook-commentary-regexp: "^;;;\$$\\|[^;]\$" +;; End: Added: branches/trunk-reorg/thirdparty/slime/swank-corman.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-corman.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-corman.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,580 @@ +;;; +;;; swank-corman.lisp --- Corman Lisp specific code for SLIME. +;;; +;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw(a)grumblesmurf.org) +;;; +;;; License +;;; ======= +;;; This software is provided 'as-is', without any express or implied +;;; warranty. In no event will the author be held liable for any damages +;;; arising from the use of this software. +;;; +;;; Permission is granted to anyone to use this software for any purpose, +;;; including commercial applications, and to alter it and redistribute +;;; it freely, subject to the following restrictions: +;;; +;;; 1. The origin of this software must not be misrepresented; you must +;;; not claim that you wrote the original software. If you use this +;;; software in a product, an acknowledgment in the product documentation +;;; would be appreciated but is not required. +;;; +;;; 2. Altered source versions must be plainly marked as such, and must +;;; not be misrepresented as being the original software. +;;; +;;; 3. This notice may not be removed or altered from any source +;;; distribution. +;;; +;;; Notes +;;; ===== +;;; You will need CCL 2.51, and you will *definitely* need to patch +;;; CCL with the patches at +;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME +;;; will blow up in your face. You should also follow the +;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime. +;;; +;;; The only communication style currently supported is NIL. +;;; +;;; Starting CCL inside emacs (with M-x slime) seems to work for me +;;; with Corman Lisp 2.51, but I have seen random failures with 2.5 +;;; (sometimes it works, other times it hangs on start or hangs when +;;; initializing WinSock) - starting CCL externally and using M-x +;;; slime-connect always works fine. +;;; +;;; Sometimes CCL gets confused and starts giving you random memory +;;; access violation errors on startup; if this happens, try redumping +;;; your image. +;;; +;;; What works +;;; ========== +;;; * Basic editing and evaluation +;;; * Arglist display +;;; * Compilation +;;; * Loading files +;;; * apropos/describe +;;; * Debugger +;;; * Inspector +;;; +;;; TODO +;;; ==== +;;; * More debugger functionality (missing bits: restart-frame, +;;; return-from-frame, disassemble-frame, activate-stepping, +;;; toggle-trace) +;;; * XREF +;;; * Profiling +;;; * More sophisticated communication styles than NIL +;;; + +(in-package :swank-backend) + +;;; Pull in various needed bits +(require :composite-streams) +(require :sockets) +(require :winbase) +(require :lp) + +(use-package :gs) + +;; MOP stuff + +(defclass swank-mop:standard-slot-definition () + () + (:documentation "Dummy class created so that swank.lisp will compile and load.")) + +(defun named-by-gensym-p (c) + (null (symbol-package (class-name c)))) + +(deftype swank-mop:eql-specializer () + '(satisfies named-by-gensym-p)) + +(defun swank-mop:eql-specializer-object (specializer) + (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*) + (loop (multiple-value-bind (more key value) + (next-entry) + (unless more (return nil)) + (when (eq specializer value) + (return key)))))) + +(defun swank-mop:class-finalized-p (class) + (declare (ignore class)) + t) + +(defun swank-mop:class-prototype (class) + (make-instance class)) + +(defun swank-mop:specializer-direct-methods (obj) + (declare (ignore obj)) + nil) + +(defun swank-mop:generic-function-argument-precedence-order (gf) + (generic-function-lambda-list gf)) + +(defun swank-mop:generic-function-method-combination (gf) + (declare (ignore gf)) + :standard) + +(defun swank-mop:generic-function-declarations (gf) + (declare (ignore gf)) + nil) + +(defun swank-mop:slot-definition-documentation (slot) + (declare (ignore slot)) + (getf slot :documentation nil)) + +(defun swank-mop:slot-definition-type (slot) + (declare (ignore slot)) + t) + +(import-swank-mop-symbols :cl '(;; classes + :standard-slot-definition + :eql-specializer + :eql-specializer-object + ;; standard class readers + :class-default-initargs + :class-direct-default-initargs + :class-finalized-p + :class-prototype + :specializer-direct-methods + ;; gf readers + :generic-function-argument-precedence-order + :generic-function-declarations + :generic-function-method-combination + ;; method readers + ;; slot readers + :slot-definition-documentation + :slot-definition-type)) + +;;;; swank implementations + +;;; Debugger + +(defvar *stack-trace* nil) +(defvar *frame-trace* nil) + +(defstruct frame + name function address debug-info variables) + +(defimplementation call-with-debugging-environment (fn) + (let* ((real-stack-trace (cl::stack-trace)) + (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace + :key #'car))) + (*frame-trace* + (let* ((db::*debug-level* (1+ db::*debug-level*)) + (db::*debug-frame-pointer* (db::stash-ebp + (ct:create-foreign-ptr))) + (db::*debug-max-level* (length real-stack-trace)) + (db::*debug-min-level* 1)) + (cdr (member #'cl:invoke-debugger + (cons + (make-frame :function nil) + (loop for i from db::*debug-min-level* + upto db::*debug-max-level* + until (eq (db::get-frame-function i) cl::*top-level*) + collect + (make-frame :function (db::get-frame-function i) + :address (db::get-frame-address i)))) + :key #'frame-function))))) + (funcall fn))) + +(defimplementation compute-backtrace (start end) + (subseq *stack-trace* start (min end (length *stack-trace*)))) + +(defimplementation print-frame (frame stream) + (format stream "~S" frame)) + +(defun get-frame-debug-info (frame) + (or (frame-debug-info frame) + (setf (frame-debug-info frame) + (db::prepare-frame-debug-info (frame-function frame) + (frame-address frame))))) + +(defimplementation frame-locals (frame-number) + (let* ((frame (elt *frame-trace* frame-number)) + (info (get-frame-debug-info frame))) + (let ((var-list + (loop for i from 4 below (length info) by 2 + collect `(list :name ',(svref info i) :id 0 + :value (db::debug-filter ,(svref info i)))))) + (let ((vars (eval-in-frame `(list ,@var-list) frame-number))) + (setf (frame-variables frame) vars))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (elt *frame-trace* frame-number))) + (let ((cl::*compiler-environment* (get-frame-debug-info frame))) + (eval form)))) + +(defimplementation frame-catch-tags (index) + (declare (ignore index)) + nil) + +(defimplementation frame-var-value (frame-number var) + (let ((vars (frame-variables (elt *frame-trace* frame-number)))) + (when vars + (second (elt vars var))))) + +(defimplementation frame-source-location-for-emacs (frame-number) + (fspec-location (frame-function (elt *frame-trace* frame-number)))) + +(defun break (&optional (format-control "Break") &rest format-arguments) + (with-simple-restart (continue "Return from BREAK.") + (let ();(*debugger-hook* nil)) + (let ((condition + (make-condition 'simple-condition + :format-control format-control + :format-arguments format-arguments))) + ;;(format *debug-io* ";;; User break: ~A~%" condition) + (invoke-debugger condition)))) + nil) + +;;; Socket communication + +(defimplementation create-socket (host port) + (sockets:start-sockets) + (sockets:make-server-socket :host host :port port)) + +(defimplementation local-port (socket) + (sockets:socket-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout external-format)) + (sockets:make-socket-stream (sockets:accept-socket socket))) + +;;; Misc + +(defimplementation preferred-communication-style () + nil) + +(defimplementation getpid () + ccl:*current-process-id*) + +(defimplementation lisp-implementation-type-name () + "cormanlisp") + +(defimplementation quit-lisp () + (sockets:stop-sockets) + (win32:exitprocess 0)) + +(defimplementation set-default-directory (directory) + (setf (ccl:current-directory) directory) + (directory-namestring (setf *default-pathname-defaults* + (truename (merge-pathnames directory))))) + +(defimplementation default-directory () + (directory-namestring (ccl:current-directory))) + +(defimplementation macroexpand-all (form) + (ccl:macroexpand-all form)) + +;;; Documentation + +(defun fspec-location (fspec) + (when (symbolp fspec) + (setq fspec (symbol-function fspec))) + (let ((file (ccl::function-source-file fspec))) + (if file + (handler-case + (let ((truename (truename + (merge-pathnames file + ccl:*cormanlisp-directory*)))) + (make-location (list :file (namestring truename)) + (if (ccl::function-source-line fspec) + (list :line + (1+ (ccl::function-source-line fspec))) + (list :function-name (princ-to-string + (function-name fspec)))))) + (error (c) (list :error (princ-to-string c)))) + (list :error (format nil "No source information available for ~S" + fspec))))) + +(defimplementation find-definitions (name) + (list (list name (fspec-location name)))) + +(defimplementation arglist (name) + (handler-case + (cond ((and (symbolp name) + (macro-function name)) + (ccl::macro-lambda-list (symbol-function name))) + (t + (when (symbolp name) + (setq name (symbol-function name))) + (if (eq (class-of name) cl::the-class-standard-gf) + (generic-function-lambda-list name) + (ccl:function-lambda-list name)))) + (error () :not-available))) + +(defimplementation function-name (fn) + (handler-case (getf (cl::function-info-list fn) 'cl::function-name) + (error () nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +;;; Compiler + +(defvar *buffer-name* nil) +(defvar *buffer-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +;; FIXME +(defimplementation call-with-compilation-hooks (FN) + (handler-bind ((error (lambda (c) + (signal (make-condition + 'compiler-condition + :original-condition c + :severity :warning + :message (format nil "~A" c) + :location + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :position *buffer-position*))) + (*compile-filename* + (make-location + (list :file *compile-filename*) + (list :position 1))) + (t + (list :error "No location")))))))) + (funcall fn))) + +(defimplementation swank-compile-file (*compile-filename* load-p + external-format) + (declare (ignore external-format)) + (with-compilation-hooks () + (let ((*buffer-name* nil)) + (compile-file *compile-filename*) + (when load-p + (load (compile-file-pathname *compile-filename*)))))) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-position* position) + (*buffer-string* string)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string))))))) + +;;;; Inspecting + +;; Hack to make swank.lisp load, at least +(defclass file-stream ()) + +(defclass corman-inspector (backend-inspector) + ()) + +(defimplementation make-default-inspector () + (make-instance 'corman-inspector)) + +(defun comma-separated (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast (loop for e in list + collect (funcall callback e) + collect ", "))) + +(defmethod inspect-for-emacs ((class standard-class) + (inspector backend-inspector)) + (declare (ignore inspector)) + (values "A class." + `("Name: " (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(comma-separated (swank-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(comma-separated + (swank-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (swank-mop:class-finalized-p class) + (comma-separated + (swank-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(princ-to-string + (swank-mop:slot-definition-name slot))))) + '("#<N/A (class not finalized)>")) + (:newline) + ,@(when (documentation class t) + `("Documentation:" (:newline) ,(documentation class t) (:newline))) + "Sub classes: " + ,@(comma-separated (swank-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub ,(princ-to-string (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (swank-mop:class-finalized-p class) + (comma-separated (swank-mop:class-precedence-list class) + (lambda (class) + `(:value ,class ,(princ-to-string (class-name class))))) + '("#<N/A (class not finalized)>")) + (:newline)))) + +(defmethod inspect-for-emacs ((slot cons) (inspector backend-inspector)) + ;; Inspects slot definitions + (declare (ignore inspector)) + (if (eq (car slot) :name) + (values "A slot." + `("Name: " (:value ,(swank-mop:slot-definition-name slot)) + (:newline) + ,@(when (swank-mop:slot-definition-documentation slot) + `("Documentation:" (:newline) + (:value ,(swank-mop:slot-definition-documentation slot)) + (:newline))) + "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline) + "Init form: " ,(if (swank-mop:slot-definition-initfunction slot) + `(:value ,(swank-mop:slot-definition-initform slot)) + "#<unspecified>") (:newline) + "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) + (:newline))) + (call-next-method))) + +(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal) + inspector) + (declare (ignore inspector)) + (values (if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + (append (label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname)))))) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (cond ((cl::structurep o) (inspect-structure o)) + (t (call-next-method)))) + +(defun inspect-structure (o) + (values + (format nil "~A is a structure" o) + (let* ((template (cl::uref o 1)) + (num-slots (cl::struct-template-num-slots template))) + (cond ((symbolp template) + (loop for i below num-slots + append (label-value-line i (cl::uref o (+ 2 i))))) + (t + (loop for i below num-slots + append (label-value-line (elt template (+ 6 (* i 5))) + (cl::uref o (+ 2 i))))))))) + + +;;; Threads + +(require 'threads) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + (lock (make-instance 'threads:critical-section)) + (queue '() :type list)) + +(defvar *mailbox-lock* (make-instance 'threads:critical-section)) +(defvar *mailboxes* (list)) + +(defmacro with-lock (lock &body body) + `(threads:with-synchronization (threads:cs ,lock) + ,@body)) + +(defimplementation spawn (fun &key name) + (declare (ignore name)) + (th:create-thread + (lambda () + (handler-bind ((serious-condition #'invoke-debugger)) + (unwind-protect (funcall fun) + (with-lock *mailbox-lock* + (setq *mailboxes* (remove cormanlisp:*current-thread-id* + *mailboxes* :key #'mailbox.thread)))))))) + +(defimplementation thread-id (thread) + thread) + +(defimplementation find-thread (thread) + (if (thread-alive-p thread) + thread)) + +(defimplementation thread-alive-p (thread) + (if (threads:thread-handle thread) t nil)) + +(defimplementation current-thread () + cormanlisp:*current-thread-id*) + +;; XXX implement it +(defimplementation all-threads () + '()) + +;; XXX something here is broken +(defimplementation kill-thread (thread) + (threads:terminate-thread thread 'killed)) + +(defun mailbox (thread) + (with-lock *mailbox-lock* + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (with-lock (mailbox.lock mbox) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(defimplementation receive () + (let ((mbox (mailbox cormanlisp:*current-thread-id*))) + (loop + (with-lock (mailbox.lock mbox) + (when (mailbox.queue mbox) + (return (pop (mailbox.queue mbox))))) + (sleep 0.1)))) + + +;;; This is probably not good, but it WFM +(in-package :common-lisp) + +(defvar *old-documentation* #'documentation) +(defun documentation (thing &optional (type 'function)) + (if (symbolp thing) + (funcall *old-documentation* thing type) + (values))) + +(defmethod print-object ((restart restart) stream) + (if (or *print-escape* + *print-readably*) + (print-unreadable-object (restart stream :type t :identity t) + (princ (restart-name restart) stream)) + (when (functionp (restart-report-function restart)) + (funcall (restart-report-function restart) stream)))) Added: branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,246 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-ecl.lisp --- SLIME backend for ECL. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(in-package :swank-backend) + +(import-from :ext *gray-stream-symbols* :swank-backend) + +(swank-backend::import-swank-mop-symbols :clos + '(:eql-specializer + :eql-specializer-object + :generic-function-declarations + :specializer-direct-methods + :compute-applicable-methods-using-classes)) + + +;;;; TCP Server + +(require 'sockets) + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket 5) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore buffering timeout external-format)) + (make-socket-io-stream (accept socket))) + +(defun make-socket-io-stream (socket) + (sb-bsd-sockets:socket-make-stream socket + :output t + :input t + :element-type 'base-char)) + +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation preferred-communication-style () + (values nil)) + + +;;;; Unix signals + +(defimplementation getpid () + (si:getpid)) + +#+nil +(defimplementation set-default-directory (directory) + (ext::chdir (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (ext::getcwd)) + (default-directory)) + +#+nil +(defimplementation default-directory () + (namestring (ext:getcwd))) + +(defimplementation quit-lisp () + (ext:quit)) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(defun signal-compiler-condition (&rest args) + (signal (apply #'make-condition 'compiler-condition args))) + +(defun handle-compiler-warning (condition) + (signal-compiler-condition + :original-condition condition + :message (format nil "~A" condition) + :severity :warning + :location + (if *buffer-name* + (make-location (list :buffer *buffer-name*) + (list :position *buffer-start-position*)) + ;; ;; compiler::*current-form* + ;; (if compiler::*current-function* + ;; (make-location (list :file *compile-filename*) + ;; (list :function-name + ;; (symbol-name + ;; (slot-value compiler::*current-function* + ;; 'compiler::name)))) + (list :error "No location found.") + ;; ) + ))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-compiler-warning)) + (funcall function))) + +(defimplementation swank-compile-file (*compile-filename* load-p + external-format) + (declare (ignore external-format)) + (with-compilation-hooks () + (let ((*buffer-name* nil)) + (multiple-value-bind (fn warn fail) + (compile-file *compile-filename*) + (when load-p (unless fail (load fn))))))) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (with-input-from-string (s string) + (compile-from-stream s :load t))))) + +(defun compile-from-stream (stream &rest args) + (let ((file (si::mkstemp "TMP:ECLXXXXXX"))) + (with-open-file (s file :direction :output :if-exists :overwrite) + (do ((line (read-line stream nil) (read-line stream nil))) + ((not line)) + (write-line line s))) + (unwind-protect + (apply #'compile-file file args) + (delete-file file)))) + + +;;;; Documentation + +(defimplementation arglist (name) + (or (functionp name) (setf name (symbol-function name))) + (if (functionp name) + (typecase name + (generic-function + (clos::generic-function-lambda-list name)) + (function + (let ((fle (function-lambda-expression name))) + (case (car fle) + (si:lambda-block (caddr fle)) + (t :not-available))))) + :not-available)) + +(defimplementation function-name (f) + (si:compiled-function-name f)) + +(defimplementation macroexpand-all (form) + ;;; FIXME! This is not the same as a recursive macroexpansion! + (macroexpand form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (dolist (type '(:VARIABLE :FUNCTION :CLASS)) + (let ((doc (describe-definition symbol type))) + (when doc + (setf result (list* type doc result))))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +;;; Debugging + +(import + '(si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands)) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* ((*tpl-commands* si::tpl-commands) + (*ihs-top* (ihs-top 'call-with-debugging-environment)) + (*ihs-current* *ihs-top*) + (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*read-suppress* nil) + (*tpl-level* (1+ *tpl-level*))) + (set-break-env) + (set-current-ihs) + (funcall debugger-loop-fn))) + +;; (defimplementation call-with-debugger-hook (hook fun) +;; (let ((*debugger-hook* hook)) +;; (funcall fun))) + +(defun nth-frame (n) + (cond ((>= n *ihs-top* ) nil) + (t (- *ihs-top* n)))) + +(defimplementation compute-backtrace (start end) + (loop for i from start below end + for f = (nth-frame i) + while f + collect f)) + +(defimplementation print-frame (frame stream) + (format stream "~A" (si::ihs-fname frame))) + +;;;; Inspector + +(defclass ecl-inspector (inspector) + ()) + +(defimplementation make-default-inspector () + (make-instance 'ecl-inspector)) + +;;;; Definitions + +(defimplementation find-definitions (name) nil) Added: branches/trunk-reorg/thirdparty/slime/swank-gray.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-gray.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-gray.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,168 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; swank-gray.lisp --- Gray stream based IO redirection. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package :swank-backend) + +(defclass slime-output-stream (fundamental-character-output-stream) + ((output-fn :initarg :output-fn) + (buffer :initform (make-string 8000)) + (fill-pointer :initform 0) + (column :initform 0) + (last-flush-time :initform (get-internal-real-time)) + (lock :initform (make-recursive-lock :name "buffer write lock")))) + +(defmethod stream-write-char ((stream slime-output-stream) char) + (call-with-recursive-lock-held + (slot-value stream 'lock) + (lambda () + (with-slots (buffer fill-pointer column) stream + (setf (schar buffer fill-pointer) char) + (incf fill-pointer) + (incf column) + (when (char= #\newline char) + (setf column 0) + (force-output stream)) + (when (= fill-pointer (length buffer)) + (finish-output stream))))) + char) + +(defmethod stream-line-column ((stream slime-output-stream)) + (call-with-recursive-lock-held + (slot-value stream 'lock) + (lambda () + (slot-value stream 'column)))) + +(defmethod stream-line-length ((stream slime-output-stream)) + 75) + +(defmethod stream-finish-output ((stream slime-output-stream)) + (call-with-recursive-lock-held + (slot-value stream 'lock) + (lambda () + (with-slots (buffer fill-pointer output-fn last-flush-time) stream + (let ((end fill-pointer)) + (unless (zerop end) + (funcall output-fn (subseq buffer 0 end)) + (setf fill-pointer 0))) + (setf last-flush-time (get-internal-real-time))))) + nil) + +(defmethod stream-force-output ((stream slime-output-stream)) + (call-with-recursive-lock-held + (slot-value stream 'lock) + (lambda () + (with-slots (last-flush-time fill-pointer) stream + (let ((now (get-internal-real-time))) + (when (> (/ (- now last-flush-time) + (coerce internal-time-units-per-second 'double-float)) + 0.2) + (finish-output stream)))))) + nil) + +(defmethod stream-fresh-line ((stream slime-output-stream)) + (call-with-recursive-lock-held + (slot-value stream 'lock) + (lambda () + (with-slots (column) stream + (cond ((zerop column) nil) + (t (terpri stream) t)))))) + +(defclass slime-input-stream (fundamental-character-input-stream) + ((output-stream :initarg :output-stream) + (input-fn :initarg :input-fn) + (buffer :initform "") (index :initform 0) + (lock :initform (make-lock :name "buffer read lock")))) + +(defmethod stream-read-char ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index output-stream input-fn) s + (when (= index (length buffer)) + (when output-stream + (finish-output output-stream)) + (let ((string (funcall input-fn))) + (cond ((zerop (length string)) + (return-from stream-read-char :eof)) + (t + (setf buffer string) + (setf index 0))))) + (assert (plusp (length buffer))) + (prog1 (aref buffer index) (incf index)))))) + +(defmethod stream-listen ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (< index (length buffer)))))) + +(defmethod stream-unread-char ((s slime-input-stream) char) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (decf index) + (cond ((eql (aref buffer index) char) + (setf (aref buffer index) char)) + (t + (warn "stream-unread-char: ignoring ~S (expected ~S)" + char (aref buffer index))))))) + nil) + +(defmethod stream-clear-input ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (setf buffer "" + index 0)))) + nil) + +(defmethod stream-line-column ((s slime-input-stream)) + nil) + +(defmethod stream-line-length ((s slime-input-stream)) + 75) + + +;;; CLISP extensions + +;; We have to define an additional method for the sake of the C +;; function listen_char (see src/stream.d), on which SYS::READ-FORM +;; depends. + +;; We could make do with either of the two methods below. + +(defmethod stream-read-char-no-hang ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (when (< index (length buffer)) + (prog1 (aref buffer index) (incf index))))))) + +;; This CLISP extension is what listen_char actually calls. The +;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit +;; more efficient to define it directly. + +(defmethod stream-read-char-will-hang-p ((s slime-input-stream)) + (with-slots (buffer index) s + (= index (length buffer)))) + + +;;; +(defimplementation make-fn-streams (input-fn output-fn) + (let* ((output (make-instance 'slime-output-stream + :output-fn output-fn)) + (input (make-instance 'slime-input-stream + :input-fn input-fn + :output-stream output))) + (values input output))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,803 @@ +;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-lispworks.lisp --- LispWorks specific code for SLIME. +;;; +;;; Created 2003, Helmut Eller +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package :swank-backend) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm") + (import-from :stream *gray-stream-symbols* :swank-backend)) + +(import-swank-mop-symbols :clos '(:slot-definition-documentation + :eql-specializer + :eql-specializer-object + :compute-applicable-methods-using-classes)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + +(defun swank-mop:compute-applicable-methods-using-classes (gf classes) + (clos::compute-applicable-methods-from-classes gf classes)) + +;; lispworks doesn't have the eql-specializer class, it represents +;; them as a list of `(EQL ,OBJECT) +(deftype swank-mop:eql-specializer () 'cons) + +(defun swank-mop:eql-specializer-object (eql-spec) + (second eql-spec)) + +(when (fboundp 'dspec::define-dspec-alias) + (dspec::define-dspec-alias defimplementation (name args &rest body) + `(defmethod ,name ,args ,@body))) + +;;; TCP server + +(defimplementation preferred-communication-style () + :spawn) + +(defun socket-fd (socket) + (etypecase socket + (fixnum socket) + (comm:socket-stream (comm:socket-stream-socket socket)))) + +(defimplementation create-socket (host port) + (multiple-value-bind (socket where errno) + #-(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port :address host) + #+(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port) + (cond (socket socket) + (t (error 'network-error + :format-control "~A failed: ~A (~D)" + :format-arguments (list where + (list #+unix (lw:get-unix-error errno)) + errno)))))) + +(defimplementation local-port (socket) + (nth-value 1 (comm:get-socket-address (socket-fd socket)))) + +(defimplementation close-socket (socket) + (comm::close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout external-format)) + (let* ((fd (comm::get-fd-from-socket socket))) + (assert (/= fd -1)) + (make-instance 'comm:socket-stream :socket fd :direction :io + :element-type 'base-char))) + +(defun set-sigint-handler () + ;; Set SIGINT handler on Swank request handler thread. + #-win32 + (sys::set-signal-handler +sigint+ + (make-sigint-handler mp:*current-process*))) + +;;; Coding Systems + +(defvar *external-format-to-coding-system* + '(((:latin-1 :eol-style :lf) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + ((:latin-1) + "latin-1" "iso-latin-1" "iso-8859-1") + ((:utf-8) "utf-8") + ((:utf-8 :eol-style :lf) "utf-8-unix") + ((:euc-jp) "euc-jp") + ((:euc-jp :eol-style :lf) "euc-jp-unix") + ((:ascii) "us-ascii") + ((:ascii :eol-style :lf) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +;;; Unix signals + +(defun sigint-handler () + (with-simple-restart (continue "Continue from SIGINT handler.") + (invoke-debugger "SIGINT"))) + +(defun make-sigint-handler (process) + (lambda (&rest args) + (declare (ignore args)) + (mp:process-interrupt process #'sigint-handler))) + +(defimplementation call-without-interrupts (fn) + (lw:without-interrupts (funcall fn))) + +(defimplementation getpid () + #+win32 (win32:get-current-process-id) + #-win32 (system::getpid)) + +(defimplementation lisp-implementation-type-name () + "lispworks") + +(defimplementation set-default-directory (directory) + (namestring (hcl:change-directory directory))) + +;;;; Documentation + +(defimplementation arglist (symbol-or-function) + (let ((arglist (lw:function-lambda-list symbol-or-function))) + (etypecase arglist + ((member :dont-know) + :not-available) + (list + arglist)))) + +(defimplementation function-name (function) + (nth-value 2 (function-lambda-expression function))) + +(defimplementation macroexpand-all (form) + (walker:walk-form form)) + +(defun generic-function-p (object) + (typep object 'generic-function)) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (labels ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos)))) + (doc (kind &optional (sym symbol)) + (let ((string (documentation sym kind))) + (if string + (first-line string) + :not-documented))) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :generic-function (if (and (fboundp symbol) + (generic-function-p (fdefinition symbol))) + (doc 'function))) + (maybe-push + :function (if (and (fboundp symbol) + (not (generic-function-p (fdefinition symbol)))) + (doc 'function))) + (maybe-push + :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol)))) + (if (fboundp setf-name) + (doc 'setf)))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol type) + (ecase type + (:variable (describe-symbol symbol)) + (:class (describe (find-class symbol))) + ((:function :generic-function) (describe-function symbol)) + (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol)))))) + +(defun describe-function (symbol) + (cond ((fboundp symbol) + (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%" + (string-downcase symbol) + (mapcar #'string-upcase + (lispworks:function-lambda-list symbol)) + (documentation symbol 'function)) + (describe (fdefinition symbol))) + (t (format t "~S is not fbound" symbol)))) + +(defun describe-symbol (sym) + (format t "~A is a symbol in package ~A." sym (symbol-package sym)) + (when (boundp sym) + (format t "~%~%Value: ~A" (symbol-value sym))) + (let ((doc (documentation sym 'variable))) + (when doc + (format t "~%~%Variable documentation:~%~A" doc))) + (when (fboundp sym) + (describe-function sym))) + +;;; Debugging + +(defclass slime-env (env:environment) + ((debugger-hook :initarg :debugger-hoook))) + +(defun slime-env (hook io-bindings) + (make-instance 'slime-env :name "SLIME Environment" + :io-bindings io-bindings + :debugger-hoook hook)) + +(defmethod env-internals:environment-display-notifier + ((env slime-env) &key restarts condition) + (declare (ignore restarts)) + (funcall (slot-value env 'debugger-hook) condition *debugger-hook*)) + +(defmethod env-internals:environment-display-debugger ((env slime-env)) + *debug-io*) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook)) + (env:with-environment ((slime-env hook '())) + (funcall fun)))) + +(defvar *sldb-top-frame*) + +(defun interesting-frame-p (frame) + (cond ((or (dbg::call-frame-p frame) + (dbg::derived-call-frame-p frame) + (dbg::foreign-frame-p frame) + (dbg::interpreted-call-frame-p frame)) + t) + ((dbg::catch-frame-p frame) dbg:*print-catch-frames*) + ((dbg::binding-frame-p frame) dbg:*print-binding-frames*) + ((dbg::handler-frame-p frame) dbg:*print-handler-frames*) + ((dbg::restart-frame-p frame) dbg:*print-restart-frames*) + ((dbg::open-frame-p frame) dbg:*print-open-frames*) + (t nil))) + +(defun nth-next-frame (frame n) + "Unwind FRAME N times." + (do ((frame frame (dbg::frame-next frame)) + (i n (if (interesting-frame-p frame) (1- i) i))) + ((or (not frame) + (and (interesting-frame-p frame) (zerop i))) + frame))) + +(defun nth-frame (index) + (nth-next-frame *sldb-top-frame* index)) + +(defun find-top-frame () + "Return the most suitable top-frame for the debugger." + (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*) + (nth-next-frame frame 1))) + ((or (null frame) ; no frame found! + (and (dbg::call-frame-p frame) + (eq (dbg::call-frame-function-name frame) + 'invoke-debugger))) + (nth-next-frame frame 1))) + ;; if we can't find a invoke-debugger frame, take any old frame at the top + (dbg::debugger-stack-current-frame dbg::*debugger-stack*))) + +(defimplementation call-with-debugging-environment (fn) + (dbg::with-debugger-stack () + (let ((*sldb-top-frame* (find-top-frame))) + (funcall fn)))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum)) + (backtrace '())) + (do ((frame (nth-frame start) (dbg::frame-next frame)) + (i start)) + ((or (not frame) (= i end)) (nreverse backtrace)) + (when (interesting-frame-p frame) + (incf i) + (push frame backtrace))))) + +(defun frame-actual-args (frame) + (let ((*break-on-signals* nil)) + (mapcar (lambda (arg) + (case arg + ((&rest &optional &key) arg) + (t + (handler-case (dbg::dbg-eval arg frame) + (error (e) (format nil "<~A>" arg)))))) + (dbg::call-frame-arglist frame)))) + +(defimplementation print-frame (frame stream) + (cond ((dbg::call-frame-p frame) + (format stream "~S ~S" + (dbg::call-frame-function-name frame) + (frame-actual-args frame))) + (t (princ frame stream)))) + +(defun frame-vars (frame) + (first (dbg::frame-locals-format-list frame #'list 75 0))) + +(defimplementation frame-locals (n) + (let ((frame (nth-frame n))) + (if (dbg::call-frame-p frame) + (mapcar (lambda (var) + (destructuring-bind (name value symbol location) var + (declare (ignore name location)) + (list :name symbol :id 0 + :value value))) + (frame-vars frame))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (destructuring-bind (_n value _s _l) (nth var (frame-vars frame)) + (declare (ignore _n _s _l)) + value))) + +(defimplementation frame-catch-tags (index) + (declare (ignore index)) + nil) + +(defimplementation frame-source-location-for-emacs (frame) + (let ((frame (nth-frame frame)) + (callee (if (plusp frame) (nth-frame (1- frame))))) + (if (dbg::call-frame-p frame) + (let ((dspec (dbg::call-frame-function-name frame)) + (cname (and (dbg::call-frame-p callee) + (dbg::call-frame-function-name callee)))) + (if dspec + (frame-location dspec cname)))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::dbg-eval form frame))) + +(defimplementation return-from-frame (frame-number form) + (let* ((frame (nth-frame frame-number)) + (return-frame (dbg::find-frame-for-return frame))) + (dbg::dbg-return-from-call-frame frame form return-frame + dbg::*debugger-stack*))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::restart-frame frame :same-args t))) + +;;; Definition finding + +(defun frame-location (dspec callee-name) + (let ((infos (dspec:find-dspec-locations dspec))) + (cond (infos + (destructuring-bind ((rdspec location) &rest _) infos + (declare (ignore _)) + (let ((name (and callee-name (symbolp callee-name) + (string callee-name)))) + (make-dspec-location rdspec location + `(:call-site ,name))))) + (t + (list :error (format nil "Source location not available for: ~S" + dspec)))))) + +(defimplementation find-definitions (name) + (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name))) + (loop for (dspec location) in locations + collect (list dspec (make-dspec-location dspec location))))) + + +;;; Compilation + +(defmacro with-swank-compilation-unit ((location &rest options) &body body) + (lw:rebinding (location) + `(let ((compiler::*error-database* '())) + (with-compilation-unit ,options + ,@body + (signal-error-data-base compiler::*error-database* ,location) + (signal-undefined-functions compiler::*unknown-functions* ,location))))) + +(defimplementation swank-compile-file (filename load-p external-format) + (with-swank-compilation-unit (filename) + (compile-file filename :load load-p :external-format external-format))) + +(defvar *within-call-with-compilation-hooks* nil + "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.") + +(defvar *undefined-functions-hash* nil + "Hash table to map info about undefined functions to pathnames.") + +(lw:defadvice (compile-file compile-file-and-collect-notes :around) + (pathname &rest rest) + (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest) + (when *within-call-with-compilation-hooks* + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (let ((unfun-info (list unfun dspec))) + (unless (gethash unfun-info *undefined-functions-hash*) + (setf (gethash unfun-info *undefined-functions-hash*) + pathname))))) + compiler::*unknown-functions*)))) + +(defimplementation call-with-compilation-hooks (function) + (let ((compiler::*error-database* '()) + (*undefined-functions-hash* (make-hash-table :test 'equal)) + (*within-call-with-compilation-hooks* t)) + (with-compilation-unit () + (prog1 (funcall function) + (signal-error-data-base compiler::*error-database*) + (signal-undefined-functions compiler::*unknown-functions*))))) + +(defun map-error-database (database fn) + (loop for (filename . defs) in database do + (loop for (dspec . conditions) in defs do + (dolist (c conditions) + (funcall fn filename dspec c))))) + +(defun lispworks-severity (condition) + (cond ((not condition) :warning) + (t (etypecase condition + (error :error) + (style-warning :warning) + (warning :warning))))) + +(defun signal-compiler-condition (message location condition) + (check-type message string) + (signal + (make-instance 'compiler-condition :message message + :severity (lispworks-severity condition) + :location location + :original-condition condition))) + +(defun compile-from-temp-file (string filename) + (unwind-protect + (progn + (with-open-file (s filename :direction :output :if-exists :supersede) + (write-string string s) + (finish-output s)) + (let ((binary-filename (compile-file filename :load t))) + (when binary-filename + (delete-file binary-filename)))) + (delete-file filename))) + +(defun dspec-buffer-position (dspec offset) + (etypecase dspec + (cons (let ((name (dspec:dspec-primary-name dspec))) + (typecase name + ((or symbol string) + (list :function-name (string name))) + (t (list :position offset))))) + (null (list :position offset)) + (symbol (list :function-name (string dspec))))) + +(defmacro with-fairly-standard-io-syntax (&body body) + "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*." + (let ((package (gensym)) + (readtable (gensym))) + `(let ((,package *package*) + (,readtable *readtable*)) + (with-standard-io-syntax + (let ((*package* ,package) + (*readtable* ,readtable)) + ,@body))))) + +#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3 +(defun dspec-stream-position (stream dspec) + (with-fairly-standard-io-syntax + (loop (let* ((pos (file-position stream)) + (form (read stream nil '#1=#:eof))) + (when (eq form '#1#) + (return nil)) + (labels ((check-dspec (form) + (when (consp form) + (let ((operator (car form))) + (case operator + ((progn) + (mapcar #'check-dspec + (cdr form))) + ((eval-when locally macrolet symbol-macrolet) + (mapcar #'check-dspec + (cddr form))) + ((in-package) + (let ((package (find-package (second form)))) + (when package + (setq *package* package)))) + (otherwise + (let ((form-dspec (dspec:parse-form-dspec form))) + (when (dspec:dspec-equal dspec form-dspec) + (return pos))))))))) + (check-dspec form)))))) + +(defun dspec-file-position (file dspec) + (let* ((*compile-file-pathname* (pathname file)) + (*compile-file-truename* (truename *compile-file-pathname*)) + (*load-pathname* *compile-file-pathname*) + (*load-truename* *compile-file-truename*)) + (with-open-file (stream file) + (let ((pos + #-(or lispworks4.1 lispworks4.2) + (dspec-stream-position stream dspec))) + (if pos + (list :position (1+ pos) t) + (dspec-buffer-position dspec 1)))))) + +(defun emacs-buffer-location-p (location) + (and (consp location) + (eq (car location) :emacs-buffer))) + +(defun make-dspec-location (dspec location &optional hints) + (etypecase location + ((or pathname string) + (multiple-value-bind (file err) + (ignore-errors (namestring (truename location))) + (if err + (list :error (princ-to-string err)) + (make-location `(:file ,file) + (dspec-file-position file dspec) + hints)))) + (symbol + `(:error ,(format nil "Cannot resolve location: ~S" location))) + ((satisfies emacs-buffer-location-p) + (destructuring-bind (_ buffer offset string) location + (declare (ignore _ string)) + (make-location `(:buffer ,buffer) + (dspec-buffer-position dspec offset) + hints))))) + +(defun make-dspec-progenitor-location (dspec location) + (let ((canon-dspec (dspec:canonicalize-dspec dspec))) + (make-dspec-location + (if canon-dspec + (if (dspec:local-dspec-p canon-dspec) + (dspec:dspec-progenitor canon-dspec) + canon-dspec) + nil) + location))) + +(defun signal-error-data-base (database &optional location) + (map-error-database + database + (lambda (filename dspec condition) + (signal-compiler-condition + (format nil "~A" condition) + (make-dspec-progenitor-location dspec (or location filename)) + condition)))) + +(defun unmangle-unfun (symbol) + "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to +function names like \(SETF GET)." + (or (and (eq (symbol-package symbol) + (load-time-value (find-package :setf))) + (let ((slime-nregex::*regex-groupings* 0) + (slime-nregex::*regex-groups* (make-array 10)) + (symbol-name (symbol-name symbol))) + (and (funcall (load-time-value + (compile nil (slime-nregex:regex-compile "^\"(.+)\" \"(.+)\"$"))) + symbol-name) + (list 'setf + (intern (apply #'subseq symbol-name + (aref slime-nregex::*regex-groups* 2)) + (find-package + (apply #'subseq symbol-name + (aref slime-nregex::*regex-groups* 1)))))))) + symbol)) + +(defun signal-undefined-functions (htab &optional filename) + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (signal-compiler-condition + (format nil "Undefined function ~A" (unmangle-unfun unfun)) + (make-dspec-progenitor-location dspec + (or filename + (gethash (list unfun dspec) + *undefined-functions-hash*))) + nil))) + htab)) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (assert buffer) + (assert position) + (let* ((location (list :emacs-buffer buffer position string)) + (tmpname (hcl:make-temp-file nil "lisp"))) + (with-swank-compilation-unit (location) + (compile-from-temp-file + (with-output-to-string (s) + (let ((*print-radix* t)) + (print `(eval-when (:compile-toplevel) + (setq dspec::*location* (list ,@location))) + s)) + (write-string string s)) + tmpname)))) + +;;; xref + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls hcl:who-calls) +(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too +(defxref calls-who hcl:calls-who) +(defxref list-callers list-callers-internal) +;; (defxref list-callees list-callees-internal) + +(defun list-callers-internal (name) + (let ((callers (make-array 100 + :fill-pointer 0 + :adjustable t))) + (hcl:sweep-all-objects + #'(lambda (object) + (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object) + #-Harlequin-PC-Lisp (sys::callablep object) + (system::find-constant$funcallable name object)) + (vector-push-extend object callers)))) + ;; Delay dspec:object-dspec until after sweep-all-objects + ;; to reduce allocation problems. + (loop for object across callers + collect (if (symbolp object) + (list 'function object) + (or (dspec:object-dspec object) object))))) + +;; only for lispworks 4.2 and above +#-lispworks4.1 +(progn + (defxref who-references hcl:who-references) + (defxref who-binds hcl:who-binds) + (defxref who-sets hcl:who-sets)) + +(defimplementation who-specializes (classname) + (let ((methods (clos:class-direct-methods (find-class classname)))) + (xref-results (mapcar #'dspec:object-dspec methods)))) + +(defun xref-results (dspecs) + (flet ((frob-locs (dspec locs) + (cond (locs + (loop for (name loc) in locs + collect (list name (make-dspec-location name loc)))) + (t `((,dspec (:error "Source location not available"))))))) + (loop for dspec in dspecs + append (frob-locs dspec (dspec:dspec-definition-locations dspec))))) + +;;; Inspector +(defclass lispworks-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'lispworks-inspector)) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (declare (ignore inspector)) + (lispworks-inspect o)) + +(defmethod inspect-for-emacs ((o function) + (inspector backend-inspector)) + (declare (ignore inspector)) + (lispworks-inspect o)) + +;; FIXME: slot-boundp-using-class in LW works with names so we can't +;; use our method in swank.lisp. +(defmethod inspect-for-emacs ((o standard-object) + (inspector backend-inspector)) + (declare (ignore inspector)) + (lispworks-inspect o)) + +(defun lispworks-inspect (o) + (multiple-value-bind (names values _getter _setter type) + (lw:get-inspector-values o nil) + (declare (ignore _getter _setter)) + (values "A value." + (append + (label-value-line "Type" type) + (loop for name in names + for value in values + append (label-value-line name value)))))) + +;;; Miscellaneous + +(defimplementation quit-lisp () + (lispworks:quit)) + +;;; Tracing + +(defun parse-fspec (fspec) + "Return a dspec for FSPEC." + (ecase (car fspec) + ((:defmethod) `(method ,(cdr fspec))))) + +(defun tracedp (dspec) + (member dspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (dspec) + (cond ((tracedp dspec) + (eval `(untrace ,dspec)) + (format nil "~S is now untraced." dspec)) + (t + (eval `(trace (,dspec))) + (format nil "~S is now traced." dspec)))) + +(defimplementation toggle-trace (fspec) + (toggle-trace-aux (parse-fspec fspec))) + +;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (cond ((not mp::*multiprocessing*) + (push (list "Initialize SLIME" '() continuation) + mp:*initial-processes*) + (mp:initialize-multiprocessing)) + (t (funcall continuation)))) + +(defimplementation spawn (fn &key name) + (let ((mp:*process-initial-bindings* + (remove (find-package :cl) + mp:*process-initial-bindings* + :key (lambda (x) (symbol-package (car x)))))) + (mp:process-run-function name () fn))) + +(defvar *id-lock* (mp:make-lock)) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-lock (*id-lock*) + (or (getf (mp:process-plist thread) 'id) + (setf (getf (mp:process-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (mp:list-all-processes) + :key (lambda (p) (getf (mp:process-plist p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A ~D" + (mp:process-whostate thread) + (mp:process-priority thread))) + +(defimplementation make-lock (&key name) + (mp:make-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (mp:list-all-processes)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defimplementation thread-alive-p (thread) + (mp:process-alive-p thread)) + +(defvar *mailbox-lock* (mp:make-lock)) + +(defun mailbox (thread) + (mp:with-lock (*mailbox-lock*) + (or (getf (mp:process-plist thread) 'mailbox) + (setf (getf (mp:process-plist thread) 'mailbox) + (mp:make-mailbox))))) + +(defimplementation receive () + (mp:mailbox-read (mailbox mp:*current-process*))) + +(defimplementation send (thread object) + (mp:mailbox-send (mailbox thread) object)) + +;;; Some intergration with the lispworks environment + +(defun swank-sym (name) (find-symbol (string name) :swank)) + +(defimplementation emacs-connected () + (when (eq (eval (swank-sym :*communication-style*)) + nil) + (set-sigint-handler)) + ;; pop up the slime debugger by default + (let ((lw:*handle-warn-on-redefinition* :warn)) + (defmethod env-internals:environment-display-notifier + (env &key restarts condition) + (declare (ignore restarts)) + (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)) + (defmethod env-internals:environment-display-debugger (env) + *debug-io*))) + +(defimplementation make-stream-interactive (stream) + (unless (find-method #'stream:stream-soft-force-output nil `((eql ,stream)) + nil) + (let ((lw:*handle-warn-on-redefinition* :warn)) + (defmethod stream:stream-soft-force-output ((o (eql stream))) + (force-output o))))) + +(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) + (apply (swank-sym :y-or-n-p-in-emacs) msg args)) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-kind :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak-kind :value args)) Added: branches/trunk-reorg/thirdparty/slime/swank-loader.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-loader.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-loader.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,236 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; swank-loader.lisp --- Compile and load the Slime backend. +;;; +;;; Created 2003, James Bielman <jamesjb(a)jamesjb.com> +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;; If you want customize the source- or fasl-directory you can set +;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory* +;; before loading this files. (you also need to create the +;; swank-loader package.) +;; E.g.: +;; +;; (make-package :swank-loader) +;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/") +;; (load ".../swank-loader.lisp") + +(cl:defpackage :swank-loader + (:use :cl) + (:export :load-swank + :*source-directory* + :*fasl-directory*)) + +(cl:in-package :swank-loader) + +(defvar *source-directory* + (make-pathname :name nil :type nil + :defaults (or *load-pathname* *default-pathname-defaults*)) + "The directory where to look for the source.") + +(defparameter *sysdep-files* + (append + '("nregex") + #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl") + #+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl") + #+sbcl '("swank-source-path-parser" "swank-source-file-cache" + "swank-sbcl" "swank-gray") + #+openmcl '("metering" "swank-openmcl" "swank-gray") + #+lispworks '("swank-lispworks" "swank-gray") + #+allegro '("swank-allegro" "swank-gray") + #+clisp '("xref" "metering" "swank-clisp" "swank-gray") + #+armedbear '("swank-abcl") + #+cormanlisp '("swank-corman" "swank-gray") + #+ecl '("swank-ecl" "swank-gray") + )) + +(defparameter *implementation-features* + '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp + :armedbear :gcl :ecl :scl)) + +(defparameter *os-features* + '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux + :unix)) + +(defparameter *architecture-features* + '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386 + :sparc64 :sparc :hppa64 :hppa)) + +(defun lisp-version-string () + #+cmu (substitute-if #\_ (lambda (x) (find x " /")) + (lisp-implementation-version)) + #+scl (lisp-implementation-version) + #+sbcl (lisp-implementation-version) + #+ecl (lisp-implementation-version) + #+openmcl (format nil "~d.~d" + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version*) + #+lispworks (lisp-implementation-version) + #+allegro (format nil + "~A~A~A" + excl::*common-lisp-version-number* + (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn + (if (member :64bit *features*) "-64bit" "")) + #+clisp (let ((s (lisp-implementation-version))) + (subseq s 0 (position #\space s))) + #+armedbear (lisp-implementation-version) + #+cormanlisp (lisp-implementation-version)) + +(defun unique-directory-name () + "Return a name that can be used as a directory name that is +unique to a Lisp implementation, Lisp implementation version, +operating system, and hardware architecture." + (flet ((first-of (features) + (loop for f in features + when (find f *features*) return it)) + (maybe-warn (value fstring &rest args) + (cond (value) + (t (apply #'warn fstring args) + "unknown")))) + (let ((lisp (maybe-warn (first-of *implementation-features*) + "No implementation feature found in ~a." + *implementation-features*)) + (os (maybe-warn (first-of *os-features*) + "No os feature found in ~a." *os-features*)) + (arch (maybe-warn (first-of *architecture-features*) + "No architecture feature found in ~a." + *architecture-features*)) + (version (maybe-warn (lisp-version-string) + "Don't know how to get Lisp ~ + implementation version."))) + (format nil "~(~@{~a~^-~}~)" lisp version os arch)))) + +(defun file-newer-p (new-file old-file) + "Returns true if NEW-FILE is newer than OLD-FILE." + (> (file-write-date new-file) (file-write-date old-file))) + +(defun slime-version-string () + "Return a string identifying the SLIME version. +Return nil if nothing appropriate is available." + (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*) + :if-does-not-exist nil) + (and s (symbol-name (read s))))) + +(defun default-fasl-directory () + (merge-pathnames + (make-pathname + :directory `(:relative ".slime" "fasl" + ,@(if (slime-version-string) (list (slime-version-string))) + ,(unique-directory-name))) + (user-homedir-pathname))) + +(defun binary-pathname (source-pathname binary-directory) + "Return the pathname where SOURCE-PATHNAME's binary should be compiled." + (let ((cfp (compile-file-pathname source-pathname))) + (merge-pathnames (make-pathname :name (pathname-name cfp) + :type (pathname-type cfp)) + binary-directory))) + +(defun handle-loadtime-error (condition binary-pathname) + (pprint-logical-block (*error-output* () :per-line-prefix ";; ") + (format *error-output* + "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%" + binary-pathname condition)) + (when (equal (directory-namestring binary-pathname) + (directory-namestring (default-fasl-directory))) + (ignore-errors (delete-file binary-pathname))) + (abort)) + +(defun compile-files-if-needed-serially (files fasl-directory load) + "Compile each file in FILES if the source is newer than +its corresponding binary, or the file preceding it was +recompiled." + (let ((needs-recompile nil)) + (dolist (source-pathname files) + (let ((binary-pathname (binary-pathname source-pathname + fasl-directory))) + (handler-case + (progn + (when (or needs-recompile + (not (probe-file binary-pathname)) + (file-newer-p source-pathname binary-pathname)) + ;; need a to recompile source-pathname, so we'll + ;; need to recompile everything after this too. + (setq needs-recompile t) + (ensure-directories-exist binary-pathname) + (compile-file source-pathname :output-file binary-pathname + :print nil + :verbose t)) + (when load + (load binary-pathname :verbose t))) + ;; Fail as early as possible + (serious-condition (c) + (handle-loadtime-error c binary-pathname))))))) + +#+(or cormanlisp ecl) +(defun compile-files-if-needed-serially (files fasl-directory) + "Corman Lisp and ECL have trouble with compiled files." + (declare (ignore fasl-directory)) + (dolist (file files) + (load file :verbose t) + (force-output))) + +(defun load-user-init-file () + "Load the user init file, return NIL if it does not exist." + (load (merge-pathnames (user-homedir-pathname) + (make-pathname :name ".swank" :type "lisp")) + :if-does-not-exist nil)) + +(defun load-site-init-file (directory) + (load (make-pathname :name "site-init" :type "lisp" + :defaults directory) + :if-does-not-exist nil)) + +(defun source-files (names src-dir) + (mapcar (lambda (name) + (make-pathname :name (string-downcase name) :type "lisp" + :defaults src-dir)) + names)) + +(defun swank-source-files (src-dir) + (source-files `("swank-backend" ,@*sysdep-files* "swank") + src-dir)) + +(defvar *fasl-directory* (default-fasl-directory) + "The directory where fasl files should be placed.") + +(defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy + swank-fancy-inspector + swank-presentations swank-presentation-streams + #+(or asdf sbcl) swank-asdf + ) + "List of names for contrib modules.") + +(defun append-dir (absolute name) + (merge-pathnames + (make-pathname :directory `(:relative ,name) :defaults absolute) + absolute)) + +(defun contrib-src-dir (src-dir) + (append-dir src-dir "contrib")) + +(defun contrib-source-files (src-dir) + (source-files *contribs* (contrib-src-dir src-dir))) + +(defun load-swank (&key + (source-directory *source-directory*) + (fasl-directory *fasl-directory*) + (contrib-fasl-directory + (append-dir fasl-directory "contrib"))) + (compile-files-if-needed-serially (swank-source-files source-directory) + fasl-directory t) + (compile-files-if-needed-serially (contrib-source-files source-directory) + contrib-fasl-directory nil)) + +(load-swank) + +(setq swank::*swank-wire-protocol-version* (slime-version-string)) +(setq swank::*load-path* + (append swank::*load-path* (list (contrib-src-dir *source-directory*)))) +(swank-backend::warn-unimplemented-interfaces) +(load-site-init-file *source-directory*) +(load-user-init-file) +(swank:run-after-init-hook) Added: branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,985 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; openmcl-swank.lisp --- SLIME backend for OpenMCL. +;;; +;;; Copyright (C) 2003, James Bielman <jamesjb(a)jamesjb.com> +;;; +;;; This program is licensed under the terms of the Lisp Lesser GNU +;;; Public License, known as the LLGPL, and distributed with OpenMCL +;;; as the file "LICENSE". The LLGPL consists of a preamble and the +;;; LGPL, which is distributed with OpenMCL as the file "LGPL". Where +;;; these conflict, the preamble takes precedence. +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; +;;; This is the beginning of a Slime backend for OpenMCL. It has been +;;; tested only with OpenMCL version 0.14-030901 on Darwin --- I would +;;; be interested in hearing the results with other versions. +;;; +;;; Additionally, reporting the positions of warnings accurately requires +;;; a small patch to the OpenMCL file compiler, which may be found at: +;;; +;;; http://www.jamesjb.com/slime/openmcl-warning-position.diff +;;; +;;; Things that work: +;;; +;;; * Evaluation of forms with C-M-x. +;;; * Compilation of defuns with C-c C-c. +;;; * File compilation with C-c C-k. +;;; * Most of the debugger functionality, except EVAL-IN-FRAME, +;;; FRAME-SOURCE-LOCATION, and FRAME-CATCH-TAGS. +;;; * Macroexpanding with C-c RET. +;;; * Disassembling the symbol at point with C-c M-d. +;;; * Describing symbol at point with C-c C-d. +;;; * Compiler warnings are trapped and sent to Emacs using the buffer +;;; position of the offending top level form. +;;; * Symbol completion and apropos. +;;; +;;; Things that sort of work: +;;; +;;; * WHO-CALLS is implemented but is only able to return the file a +;;; caller is defined in---source location information is not +;;; available. +;;; +;;; Things that aren't done yet: +;;; +;;; * Cross-referencing. +;;; * Due to unimplementation functionality the test suite does not +;;; run correctly (it hangs upon entering the debugger). +;;; + +(in-package :swank-backend) + +(import-from :ccl *gray-stream-symbols* :swank-backend) + +(require 'xref) + +;;; swank-mop + +(import-to-swank-mop + '( ;; classes + cl:standard-generic-function + ccl::standard-slot-definition + cl:method + cl:standard-class + ccl::eql-specializer + openmcl-mop:finalize-inheritance + ;; standard-class readers + openmcl-mop:class-default-initargs + openmcl-mop:class-direct-default-initargs + openmcl-mop:class-direct-slots + openmcl-mop:class-direct-subclasses + openmcl-mop:class-direct-superclasses + openmcl-mop:class-finalized-p + cl:class-name + openmcl-mop:class-precedence-list + openmcl-mop:class-prototype + openmcl-mop:class-slots + openmcl-mop:specializer-direct-methods + ;; eql-specializer accessors + openmcl-mop:eql-specializer-object + ;; generic function readers + openmcl-mop:generic-function-argument-precedence-order + openmcl-mop:generic-function-declarations + openmcl-mop:generic-function-lambda-list + openmcl-mop:generic-function-methods + openmcl-mop:generic-function-method-class + openmcl-mop:generic-function-method-combination + openmcl-mop:generic-function-name + ;; method readers + openmcl-mop:method-generic-function + openmcl-mop:method-function + openmcl-mop:method-lambda-list + openmcl-mop:method-specializers + openmcl-mop:method-qualifiers + ;; slot readers + openmcl-mop:slot-definition-allocation + ccl::slot-definition-documentation + openmcl-mop:slot-value-using-class + openmcl-mop:slot-definition-initargs + openmcl-mop:slot-definition-initform + openmcl-mop:slot-definition-initfunction + openmcl-mop:slot-definition-name + openmcl-mop:slot-definition-type + openmcl-mop:slot-definition-readers + openmcl-mop:slot-definition-writers + openmcl-mop:slot-boundp-using-class + openmcl-mop:slot-makunbound-using-class)) + +(defun specializer-name (spec) + (etypecase spec + (cons spec) + (class (class-name spec)) + (ccl::eql-specializer `(eql ,(ccl::eql-specializer-object spec))))) + +(defun swank-mop:compute-applicable-methods-using-classes (gf args) + (let* ((methods (ccl::%gf-methods gf)) + (args-length (length args)) + (bits (ccl::inner-lfun-bits gf)) + arg-count res) + (when methods + (setq arg-count (length (ccl::%method-specializers (car methods)))) + (unless (<= arg-count args-length) + (error "Too few args to ~s" gf)) + (unless (or (logbitp ccl::$lfbits-rest-bit bits) + (logbitp ccl::$lfbits-restv-bit bits) + (logbitp ccl::$lfbits-keys-bit bits) + (<= args-length + (+ (ldb ccl::$lfbits-numreq bits) (ldb ccl::$lfbits-numopt bits)))) + (error "Too many args to ~s" gf)) + (let ((cpls (make-list arg-count))) + (declare (dynamic-extent cpls)) + (do* ((args-tail args (cdr args-tail)) + (cpls-tail cpls (cdr cpls-tail))) + ((null cpls-tail)) + (setf (car cpls-tail) + (ccl::%class-precedence-list (car args-tail)))) + (flet ((%method-applicable-p (method args cpls) + (do* ((specs (ccl::%method-specializers method) (ccl::%cdr specs)) + (args args (ccl::%cdr args)) + (cpls cpls (ccl::%cdr cpls))) + ((null specs) t) + (let ((spec (ccl::%car specs))) + (if (typep spec 'ccl::eql-specializer) + (unless (subtypep (ccl::%car args) (class-of (ccl::eql-specializer-object spec))) + (return nil)) + (unless (ccl:memq spec (ccl::%car cpls)) + (return nil))))))) + (dolist (m methods) + (if (%method-applicable-p m args cpls) + (push m res)))) + (ccl::sort-methods res cpls (ccl::%gf-precedence-list gf)))))) + +;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port) + (ccl:make-socket :connect :passive :local-port port + :local-host host :reuse-address t)) + +(defimplementation local-port (socket) + (ccl:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format + buffering timeout) + (declare (ignore buffering timeout + #-openmcl-unicode-strings external-format)) + #+openmcl-unicode-strings + (when external-format + (let ((keys (ccl::socket-keys socket))) + (setf (getf keys :external-format) external-format + (slot-value socket 'ccl::keys) keys))) + (ccl:accept-connection socket :wait t)) + +#+openmcl-unicode-strings +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +#+openmcl-unicode-strings +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defimplementation emacs-connected () + (setq ccl::*interactive-abort-process* ccl::*current-process*)) + +(defimplementation make-stream-interactive (stream) + (typecase stream + (ccl:fundamental-output-stream + (push stream ccl::*auto-flush-streams*)))) + +;;; Unix signals + +(defimplementation call-without-interrupts (fn) + (ccl:without-interrupts (funcall fn))) + +(defimplementation getpid () + (ccl::getpid)) + +(defimplementation lisp-implementation-type-name () + "openmcl") + +(defvar *break-in-sldb* t) + +(let ((ccl::*warn-if-redefine-kernel* nil)) + (ccl::advise + cl::break + (if (and *break-in-sldb* + (find ccl::*current-process* (symbol-value (intern "*CONNECTIONS*" 'swank)) + :key (intern "CONNECTION.REPL-THREAD" 'swank))) + (apply 'break-in-sldb ccl::arglist) + (:do-it)) :when :around :name sldb-break)) + +(defun break-in-sldb (&optional string &rest args) + (let ((c (make-condition 'simple-condition + :format-control (or string "Break") + :format-arguments args))) + (let ((previous-f nil) + (previous-f2 nil)) + (block find-frame + (map-backtrace + #'(lambda(frame-number p context lfun pc) + (declare (ignore frame-number context pc)) + (when (eq previous-f2 'break-in-sldb) + (record-stack-top p) + (return-from find-frame)) + (setq previous-f2 previous-f) + (setq previous-f (ccl::lfun-name lfun))))) + (restart-case (invoke-debugger c) + (continue () :report (lambda (stream) (write-string "Resume interrupted evaluation" stream)) t)) + ))) + +; In previous version the code that recorded the function that had an +; error or which was interrupted was not thread safe. This code repairs that by +; associating the frame pointer with a process via the *process-to-stack-top* hash. + +(defvar *process-to-stack-top* (make-hash-table :test 'eql)) + +(defun record-stack-top (frame) + (setf (gethash (ccl::process-serial-number ccl::*current-process*) *process-to-stack-top* ) + frame)) + +(defun grab-stack-top () + (let ((psn (ccl::process-serial-number ccl::*current-process*))) + (ccl::without-interrupts + (prog1 + (gethash psn *process-to-stack-top*) + (setf (gethash psn *process-to-stack-top*) nil))))) + +(defmethod ccl::application-error :before (application condition error-pointer) + (declare (ignore application condition)) + (record-stack-top error-pointer) + nil) + +;;; Evaluation + +(defimplementation arglist (fname) + (arglist% fname)) + +(defmethod arglist% ((f symbol)) + (ccl:arglist f)) + +(defmethod arglist% ((f function)) + (ccl:arglist (ccl:function-name f))) + +(defimplementation function-name (function) + (ccl:function-name function)) + +;;; Compilation + +(defvar *buffer-offset* nil) +(defvar *buffer-name* nil) + +(defun condition-source-position (condition) + "Return the position in the source file of a compiler condition." + (+ 1 + (or *buffer-offset* 0) + ;; alanr sometimes returned stream position nil. + (or (ccl::compiler-warning-stream-position condition) 0))) + + +(defun handle-compiler-warning (condition) + "Construct a compiler note for Emacs from a compiler warning +condition." + (signal (make-condition + 'compiler-condition + :original-condition condition + :message (format nil "~A" condition) + :severity :warning + :location + (let ((position (condition-source-position condition))) + (if *buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :position position t)) + (if (ccl::compiler-warning-file-name condition) + (make-location + (list :file (namestring (truename (ccl::compiler-warning-file-name condition)))) + (list :position position t)))))))) + +(defun temp-file-name () + "Return a temporary file name to compile strings into." + (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr)))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((ccl::compiler-warning 'handle-compiler-warning)) + (funcall function))) + +(defimplementation swank-compile-file (filename load-p external-format) + (declare (ignore external-format)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*buffer-offset* nil)) + (compile-file filename :load load-p)))) + +(defimplementation frame-var-value (frame var) + (block frame-var-value + (map-backtrace + #'(lambda(frame-number p context lfun pc) + (when (= frame frame-number) + (return-from frame-var-value + (multiple-value-bind (total vsp parent-vsp) + (ccl::count-values-in-frame p context) + (loop for count below total + with varcount = -1 + for (value nil name) = (multiple-value-list (ccl::nth-value-in-frame p count context lfun pc vsp parent-vsp)) + when name do (incf varcount) + until (= varcount var) + finally (return value)) + ))))))) + +(defun xref-locations (relation name &optional (inverse nil)) + (flet ((function-source-location (entry) + (multiple-value-bind (info name) + (ccl::edit-definition-p + (ccl::%db-key-from-xref-entry entry) + (if (eql (ccl::xref-entry-type entry) + 'macro) + 'function + (ccl::xref-entry-type entry))) + (cond ((not info) + (list :error + (format nil "No source info available for ~A" + (ccl::xref-entry-name entry)))) + ((typep (caar info) 'ccl::method) + `(:location + (:file ,(remove-filename-quoting + (namestring (translate-logical-pathname + (cdr (car info)))))) + (:method + ,(princ-to-string (ccl::method-name (caar info))) + ,(mapcar 'princ-to-string + (mapcar #'specializer-name + (ccl::method-specializers + (caar info)))) + ,@(mapcar 'princ-to-string + (ccl::method-qualifiers (caar info)))) + nil)) + (t + (canonicalize-location (cdr (first info)) name)))))) + (declare (dynamic-extent #'function-source-location)) + (loop for xref in (if inverse + (ccl::get-relation relation name + :wild :exhaustive t) + (ccl::get-relation relation + :wild name :exhaustive t)) + for function = (ccl::xref-entry-name xref) + collect `((function ,function) + ,(function-source-location xref))))) + +(defimplementation who-binds (name) + (xref-locations :binds name)) + +(defimplementation who-macroexpands (name) + (xref-locations :macro-calls name t)) + +(defimplementation who-references (name) + (remove-duplicates + (append (xref-locations :references name) + (xref-locations :sets name) + (xref-locations :binds name)) + :test 'equal)) + +(defimplementation who-sets (name) + (xref-locations :sets name)) + +(defimplementation who-calls (name) + (remove-duplicates + (append + (xref-locations :direct-calls name) + (xref-locations :indirect-calls name) + (xref-locations :macro-calls name t)) + :test 'equal)) + +(defimplementation list-callees (name) + (remove-duplicates + (append + (xref-locations :direct-calls name t) + (xref-locations :macro-calls name nil)) + :test 'equal)) + +(defimplementation who-specializes (class) + (if (symbolp class) (setq class (find-class class))) + (remove-duplicates + (append (mapcar (lambda(m) + (let ((location (function-source-location (ccl::method-function m)))) + (if (eq (car location) :error) + (setq location nil )) + `((method ,(ccl::method-name m) + ,(mapcar #'specializer-name (ccl::method-specializers m)) + ,@(ccl::method-qualifiers m)) + ,location))) + (ccl::%class.direct-methods class)) + (mapcan 'who-specializes (ccl::%class-direct-subclasses class))) + :test 'equal)) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-offset* position) + (filename (temp-file-name))) + (unwind-protect + (with-open-file (s filename :direction :output :if-exists :error) + (write-string string s)) + (let ((binary-filename (compile-file filename :load t))) + (delete-file binary-filename))) + (delete-file filename)))) + +;;; Profiling (alanr: lifted from swank-clisp) + +(defimplementation profile (fname) + (eval `(mon:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + mon:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (mon:unmonitor)) + +(defimplementation profile-report () + (mon:report-monitoring)) + +(defimplementation profile-reset () + (mon:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (mon:monitor-all package)) + +;;; Debugging + +(defun openmcl-set-debug-switches () + (setq ccl::*fasl-save-definitions* nil) + (setq ccl::*fasl-save-doc-strings* t) + (setq ccl::*fasl-save-local-symbols* t) + (setq ccl::*ppc2-compiler-register-save-label* t) + (setq ccl::*save-arglist-info* t) + (setq ccl::*save-definitions* nil) + (setq ccl::*save-doc-strings* t) + (setq ccl::*save-local-symbols* t) + (ccl::start-xref)) + +(defvar *sldb-stack-top* nil) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((*debugger-hook* nil) + (*sldb-stack-top* (grab-stack-top)) + (ccl::*signal-printing-errors* nil)) ; don't let error while printing error take us down + (funcall debugger-loop-fn))) + +(defun backtrace-context () + (if (and (= ccl::*openmcl-major-version* 0) + (<= ccl::*openmcl-minor-version* 14) + (< ccl::*openmcl-revision* 2)) + (ccl::%current-tcr) + nil)) + +(defun map-backtrace (function &optional + (start-frame-number 0) + (end-frame-number most-positive-fixnum)) + "Call FUNCTION passing information about each stack frame + from frames START-FRAME-NUMBER to END-FRAME-NUMBER." + (let ((context (backtrace-context)) + (frame-number 0) + (top-stack-frame (or *sldb-stack-top* + (ccl::%get-frame-ptr)))) + (do* ((p top-stack-frame (ccl::parent-frame p context)) + (q (ccl::last-frame-ptr context))) + ((or (null p) (eq p q) (ccl::%stack< q p context)) + (values)) + (multiple-value-bind (lfun pc) (ccl::cfp-lfun p) + (when lfun + (if (and (>= frame-number start-frame-number) + (< frame-number end-frame-number)) + (funcall function frame-number p context lfun pc)) + (incf frame-number)))))) + +;; May 13, 2004 alanr: use prin1 instead of princ so I see " around strings. Write ' in front of symbol names and lists. +;; Sept 6, 2004 alanr: use builtin ccl::frame-supplied-args + +(defun frame-arguments (p context lfun pc) + "Returns a string representing the arguments of a frame." + (multiple-value-bind (args types names count nclosed) + (ccl::frame-supplied-args p lfun pc nil context) + (declare (ignore count nclosed)) + (let ((result nil)) + (loop named loop + for var = (cond + ((null args) + (return-from loop)) + ((atom args) + (prog1 + args + (setf args nil))) + (t (pop args))) + for type in types + for name in names + do + (when (or (symbolp var) (listp var)) (setq var (list 'quote var))) + (cond ((equal type "keyword") + (push (format nil "~S ~A" + (intern (symbol-name name) "KEYWORD") + (prin1-to-string var)) + result)) + (t (push (prin1-to-string var) result)))) + (format nil "~{ ~A~}" (nreverse result))))) + + +;; XXX should return something less stringy +;; alanr May 13, 2004: put #<> around anonymous functions in the backtrace. + +(defimplementation compute-backtrace (start-frame-number end-frame-number) + (let (result) + (map-backtrace (lambda (frame-number p context lfun pc) + (declare (ignore frame-number)) + (push (with-output-to-string (s) + (format s "(~A~A)" + (if (ccl::function-name lfun) + (ccl::%lfun-name-string lfun) + lfun) + (frame-arguments p context lfun pc))) + result)) + start-frame-number end-frame-number) + (nreverse result))) + +(defimplementation print-frame (frame stream) + (princ frame stream)) + +(defimplementation frame-locals (index) + (block frame-locals + (map-backtrace + (lambda (frame-number p context lfun pc) + (when (= frame-number index) + (multiple-value-bind (count vsp parent-vsp) + (ccl::count-values-in-frame p context) + (let (result) + (dotimes (i count) + (multiple-value-bind (var type name) + (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp) + (declare (ignore type)) + (when name + (push (list + :name name + :id 0 + :value var) + result)))) + (return-from frame-locals (nreverse result))))))))) + +(defimplementation frame-catch-tags (index &aux my-frame) + (block frame-catch-tags + (map-backtrace + (lambda (frame-number p context lfun pc) + (declare (ignore pc lfun)) + (if (= frame-number index) + (setq my-frame p) + (when my-frame + (return-from frame-catch-tags + (loop for catch = (ccl::%catch-top (ccl::%current-tcr)) then (ccl::next-catch catch) + while catch + for csp = (ccl::uvref catch 3) ; ppc32::catch-frame.csp-cell) defined in arch.lisp + for tag = (ccl::uvref catch 0) ; ppc32::catch-frame.catch-tag-cell) + until (ccl::%stack< p csp context) + when (ccl::%stack< my-frame csp context) + collect (cond + ((symbolp tag) + tag) + ((and (listp tag) + (typep (car tag) 'restart)) + `(:restart ,(restart-name (car tag))))))))))))) + +(defimplementation disassemble-frame (the-frame-number) + (let ((function-to-disassemble nil)) + (block find-frame + (map-backtrace + (lambda(frame-number p context lfun pc) + (declare (ignore p context pc)) + (when (= frame-number the-frame-number) + (setq function-to-disassemble lfun) + (return-from find-frame))))) + (ccl::print-ppc-instructions + *standard-output* + (ccl::function-to-dll-header function-to-disassemble) nil))) + +;;; + +(defun canonicalize-location (file symbol) + (etypecase file + ((or string pathname) + (multiple-value-bind (truename c) (ignore-errors (namestring (truename file))) + (cond (c (list :error (princ-to-string c))) + (t (make-location (list :file (remove-filename-quoting truename)) + (list :function-name (princ-to-string symbol))))))))) + +(defun remove-filename-quoting (string) + (if (search "\\" string) + (read-from-string (format nil "\"~a\"" string)) + string)) + +(defun maybe-method-location (type) + (when (typep type 'ccl::method) + `((method ,(ccl::method-name type) + ,(mapcar #'specializer-name (ccl::method-specializers type)) + ,@(ccl::method-qualifiers type)) + ,(function-source-location (ccl::method-function type))))) + +(defimplementation find-definitions (symbol) + (let* ((info (ccl::get-source-files-with-types&classes symbol))) + (loop for (type . file) in info + when (not (equal "l1-boot-3" (pathname-name file))) ; alanr: This is a bug - there's nothing in there + collect (or (maybe-method-location type) + (list (list type symbol) + (canonicalize-location file symbol)))))) + + +(defun function-source-location (function) + (multiple-value-bind (info name) (ccl::edit-definition-p function) + (cond ((not info) (list :error (format nil "No source info available for ~A" function))) + ((typep (caar info) 'ccl::method) + `(:location + (:file ,(remove-filename-quoting (namestring (translate-logical-pathname (cdr (car info))) ))) + (:method ,(princ-to-string (ccl::method-name (caar info))) + ,(mapcar 'princ-to-string + (mapcar #'specializer-name + (ccl::method-specializers (caar info)))) + ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info)))) + nil)) + (t (canonicalize-location (cdr (first info)) name))))) + +(defimplementation frame-source-location-for-emacs (index) + "Return to Emacs the location of the source code for the +function in a debugger frame. In OpenMCL, we are not able to +find the precise position of the frame, but we do attempt to give +at least the filename containing it." + (block frame-source-location-for-emacs + (map-backtrace + (lambda (frame-number p context lfun pc) + (declare (ignore p context pc)) + (when (and (= frame-number index) lfun) + (return-from frame-source-location-for-emacs + (function-source-location lfun))))))) + +(defimplementation eval-in-frame (form index) + (block eval-in-frame + (map-backtrace + (lambda (frame-number p context lfun pc) + (when (= frame-number index) + (multiple-value-bind (count vsp parent-vsp) + (ccl::count-values-in-frame p context) + (let ((bindings nil)) + (dotimes (i count) + (multiple-value-bind (var type name) + (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp) + (declare (ignore type)) + (when name + (push (list name `',var) bindings)) + )) + (return-from eval-in-frame + (eval `(let ,bindings + (declare (ignorable ,@(mapcar 'car bindings))) + ,form))) + ))))))) + +(defimplementation return-from-frame (index form) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (map-backtrace + (lambda (frame-number p context lfun pc) + (declare (ignore context lfun pc)) + (when (= frame-number index) + (ccl::apply-in-frame p #'values values)))))) + +(defimplementation restart-frame (index) + (map-backtrace + (lambda (frame-number p context lfun pc) + (when (= frame-number index) + (ccl::apply-in-frame p lfun + (ccl::frame-supplied-args p lfun pc nil context)))))) + +;;; Utilities + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :setf (let ((setf-function-name (ccl::setf-function-spec-name + `(setf ,symbol)))) + (when (fboundp setf-function-name) + (doc 'function setf-function-name)))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:setf + (describe (ccl::setf-function-spec-name `(setf ,symbol)))) + (:class + (describe (find-class symbol))))) + +(defimplementation toggle-trace (spec) + "We currently ignore just about everything." + (ecase (car spec) + (setf + (ccl::%trace spec)) + (:defmethod + (ccl::%trace (second spec))) + (:defgeneric + (ccl::%trace (second spec))) + (:call + (toggle-trace (third spec))) + ;; mb: FIXME: shouldn't we warn that we're not doing anything for + ;; these two? + (:labels nil) + (:flet nil)) + t) + +;;; XREF + +(defimplementation list-callers (symbol) + (loop for caller in (ccl::callers symbol) + append (multiple-value-bind (info name type specializers modifiers) + (ccl::edit-definition-p caller) + (loop for (nil . file) in info + collect (list (if (eq t type) + name + `(,type ,name ,specializers + ,@modifiers)) + (canonicalize-location file name)))))) +;;; Macroexpansion + +(defvar *value2tag* (make-hash-table)) + +(do-symbols (s (find-package 'arch)) + (if (and (> (length (symbol-name s)) 7) + (string= (symbol-name s) "SUBTAG-" :end1 7) + (boundp s) + (numberp (symbol-value s)) + (< (symbol-value s) 255)) + (setf (gethash (symbol-value s) *value2tag*) s))) + +;;;; Inspection + +(defclass openmcl-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'openmcl-inspector)) + +(defimplementation describe-primitive-type (thing) + (let ((typecode (ccl::typecode thing))) + (if (gethash typecode *value2tag*) + (string (gethash typecode *value2tag*)) + (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm)))))) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (declare (ignore inspector)) + (let* ((i (inspector::make-inspector o)) + (count (inspector::compute-line-count i)) + (lines + (loop + for l below count + for (value label) = (multiple-value-list + (inspector::line-n i l)) + collect `(:value ,label ,(string-capitalize (format nil "~a" label))) + collect " = " + collect `(:value ,value) + collect '(:newline)))) + (values (with-output-to-string (s) + (let ((*print-lines* 1) + (*print-right-margin* 80)) + (pprint o s))) + lines))) + +(defmethod inspect-for-emacs :around ((o t) (inspector backend-inspector)) + (if (or (uvector-inspector-p o) + (not (ccl:uvectorp o))) + (call-next-method) + (multiple-value-bind (title content) + (call-next-method) + (values + title + (append content + `((:newline) + (:value ,(make-instance 'uvector-inspector :object o) + "Underlying UVECTOR"))))))) + +(defclass uvector-inspector () + ((object :initarg :object))) + +(defgeneric uvector-inspector-p (object) + (:method ((object t)) nil) + (:method ((object uvector-inspector)) t)) + +(defmethod inspect-for-emacs ((uv uvector-inspector) + (inspector backend-inspector)) + (with-slots (object) + uv + (values (format nil "The UVECTOR for ~S." object) + (loop + for index below (ccl::uvsize object) + collect (format nil "~D: " index) + collect `(:value ,(ccl::uvref object index)) + collect `(:newline))))) + +(defun closure-closed-over-values (closure) + (let ((howmany (nth-value 8 (ccl::function-args (ccl::closure-function closure))))) + (loop for n below howmany + collect + (let* ((value (ccl::%svref closure (+ 1 (- howmany n)))) + (map (car (ccl::function-symbol-map (ccl::closure-function closure)))) + (label (or (and map (svref map n)) n)) + (cellp (ccl::closed-over-value-p value))) + (list label (if cellp (ccl::closed-over-value value) value)))))) + +(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure) (inspector t)) + (declare (ignore inspector)) + (values + (format nil "A closure: ~a" c) + `(,@(if (arglist c) + (list "Its argument list is: " + (funcall (intern "INSPECTOR-PRINC" 'swank) (arglist c))) + ;; FIXME inspector-princ should load earlier + (list "A function of no arguments")) + (:newline) + ,@(when (documentation c t) + `("Documentation:" (:newline) ,(documentation c t) (:newline))) + ,(format nil "Closed over ~a values" (length (closure-closed-over-values c))) + (:newline) + ,@(loop for (name value) in (closure-closed-over-values c) + for count from 1 + append + (label-value-line* ((format nil "~2,' d) ~a" count (string name)) value)))))) + + + + +;;; Multiprocessing + +(defvar *known-processes* '() ; FIXME: leakage. -luke + "Alist (ID . PROCESS MAILBOX) list of processes that we have handed +out IDs for.") + +(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*")) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (ccl:make-lock "thread mailbox")) + (semaphore (ccl:make-semaphore)) + (queue '() :type list)) + +(defimplementation spawn (fn &key name) + (ccl:process-run-function (or name "Anonymous (Swank)") fn)) + +(defimplementation thread-id (thread) + (ccl::process-serial-number thread)) + +(defimplementation find-thread (id) + (find id (ccl:all-processes) :key #'ccl::process-serial-number)) + +(defimplementation thread-name (thread) + (ccl::process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A" (ccl:process-whostate thread))) + +(defimplementation make-lock (&key name) + (ccl:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (ccl:with-lock-grabbed (lock) + (funcall function))) + +(defimplementation current-thread () + ccl:*current-process*) + +(defimplementation all-threads () + (ccl:all-processes)) + +(defimplementation kill-thread (thread) + (ccl:process-kill thread)) + +;; September 5, 2004 alanr. record the frame interrupted +(defimplementation interrupt-thread (thread fn) + (ccl:process-interrupt + thread + (lambda(&rest args) + (let ((previous-f nil)) + (block find-frame + (map-backtrace + #'(lambda(frame-number p context lfun pc) + (declare (ignore frame-number context pc)) + (when (eq previous-f 'ccl::%pascal-functions%) + (record-stack-top p) + (return-from find-frame)) + (setq previous-f (ccl::lfun-name lfun))))) + (apply fn args))))) + + +(defun mailbox (thread) + (ccl:with-lock-grabbed (*known-processes-lock*) + (let ((probe (rassoc thread *known-processes* :key #'car))) + (cond (probe (second (cdr probe))) + (t (let ((mailbox (make-mailbox))) + (setq *known-processes* + (acons (ccl::process-serial-number thread) + (list thread mailbox) + (remove-if + (lambda(entry) + (string= (ccl::process-whostate (second entry)) "Exhausted")) + *known-processes*) + )) + mailbox)))))) + +(defimplementation send (thread message) + (assert message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (ccl:with-lock-grabbed (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (ccl:signal-semaphore (mailbox.semaphore mbox))))) + +(defimplementation receive () + (let* ((mbox (mailbox ccl:*current-process*)) + (mutex (mailbox.mutex mbox))) + (ccl:wait-on-semaphore (mailbox.semaphore mbox)) + (ccl:with-lock-grabbed (mutex) + (assert (mailbox.queue mbox)) + (pop (mailbox.queue mbox))))) + +(defimplementation quit-lisp () + (ccl::quit)) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +(defimplementation hash-table-weakness (hashtable) + (ccl::hash-table-weak-p hashtable)) Added: branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,1323 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; swank-sbcl.lisp --- SLIME backend for SBCL. +;;; +;;; Created 2003, Daniel Barlow <dan(a)metacircles.com> +;;; +;;; This code has been placed in the Public Domain. All warranties are +;;; disclaimed. + +;;; Requires the SB-INTROSPECT contrib. + +;;; Administrivia + +(in-package :swank-backend) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'asdf) + (require 'sb-bsd-sockets) + (require 'sb-introspect) + (require 'sb-posix) + (require 'sb-cltl2)) + +(declaim (optimize (debug 2) (sb-c:insert-step-conditions 0))) + +(import-from :sb-gray *gray-stream-symbols* :swank-backend) + +;;; backwards compability tests + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; Generate a form suitable for testing for stepper support (0.9.17) + ;; with #+. + (defun sbcl-with-new-stepper-p () + (if (find-symbol "ENABLE-STEPPING" "SB-IMPL") + '(:and) + '(:or))) + ;; Ditto for weak hash-tables + (defun sbcl-with-weak-hash-tables () + (if (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT") + '(:and) + '(:or))) + ;; And for xref support (1.0.1) + (defun sbcl-with-xref-p () + (if (find-symbol "WHO-CALLS" "SB-INTROSPECT") + '(:and) + '(:or))) + ;; ... for restart-frame support (1.0.2) + (defun sbcl-with-restart-frame () + (if (find-symbol "FRAME-HAS-DEBUG-TAG-P" "SB-DEBUG") + '(:and) + '(:or)))) + +;;; swank-mop + +(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (sb-pcl::documentation slot t)) + +;;; TCP Server + +(defimplementation preferred-communication-style () + (cond + ;; fixme: when SBCL/win32 gains better select() support, remove + ;; this. + ((member :win32 *features*) nil) + ((member :sb-thread *features*) :spawn) + (t :fd-handler))) + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket 5) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-sys:invalidate-descriptor (socket-fd socket)) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket &key + external-format + buffering timeout) + (declare (ignore timeout)) + (make-socket-io-stream (accept socket) + (or external-format :iso-latin-1-unix) + (or buffering :full))) + +(defvar *sigio-handlers* '() + "List of (key . fn) pairs to be called on SIGIO.") + +(defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (mapc (lambda (handler) + (funcall (the function (cdr handler)))) + *sigio-handlers*)) + +(defun set-sigio-handler () + (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp) + (sigio-handler signal code scp)))) + +(defun enable-sigio-on-fd (fd) + (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async) + (sb-posix::fcntl fd sb-posix::f-setown (getpid))) + +(defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (format *debug-io* "Adding sigio handler: ~S ~%" fd) + (enable-sigio-on-fd fd) + (push (cons fd fn) *sigio-handlers*))) + +(defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car)) + (sb-sys:invalidate-descriptor fd)) + (close socket)) + +(defimplementation add-fd-handler (socket fn) + (declare (type function fn)) + (let ((fd (socket-fd socket))) + (format *debug-io* "; Adding fd handler: ~S ~%" fd) + (sb-sys:add-fd-handler fd :input (lambda (_) + _ + (funcall fn))))) + +(defimplementation remove-fd-handlers (socket) + (sb-sys:invalidate-descriptor (socket-fd socket))) + +(defun socket-fd (socket) + (etypecase socket + (fixnum socket) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (sb-sys:fd-stream-fd socket)))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix") + (:us-ascii "us-ascii" "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (socket external-format buffering) + (sb-bsd-sockets:socket-make-stream socket + :output t + :input t + :element-type 'character + :buffering buffering + #+sb-unicode :external-format + #+sb-unicode external-format + )) + +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation call-without-interrupts (fn) + (declare (type function fn)) + (sb-sys:without-interrupts (funcall fn))) + +(defimplementation getpid () + (sb-posix:getpid)) + +(defimplementation lisp-implementation-type-name () + "sbcl") + + +;;;; Support for SBCL syntax + +;;; SBCL's source code is riddled with #! reader macros. Also symbols +;;; containing `!' have special meaning. We have to work long and +;;; hard to be able to read the source. To deal with #! reader +;;; macros, we use a special readtable. The special symbols are +;;; converted by a condition handler. + +(defun feature-in-list-p (feature list) + (etypecase feature + (symbol (member feature list :test #'eq)) + (cons (flet ((subfeature-in-list-p (subfeature) + (feature-in-list-p subfeature list))) + (ecase (first feature) + (:or (some #'subfeature-in-list-p (rest feature))) + (:and (every #'subfeature-in-list-p (rest feature))) + (:not (destructuring-bind (e) (cdr feature) + (not (subfeature-in-list-p e))))))))) + +(defun shebang-reader (stream sub-character infix-parameter) + (declare (ignore sub-character)) + (when infix-parameter + (error "illegal read syntax: #~D!" infix-parameter)) + (let ((next-char (read-char stream))) + (unless (find next-char "+-") + (error "illegal read syntax: #!~C" next-char)) + ;; When test is not satisfied + ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then + ;; would become "unless test is satisfied".. + (when (let* ((*package* (find-package "KEYWORD")) + (*read-suppress* nil) + (not-p (char= next-char #\-)) + (feature (read stream))) + (if (feature-in-list-p feature *features*) + not-p + (not not-p))) + ;; Read (and discard) a form from input. + (let ((*read-suppress* t)) + (read stream t nil t)))) + (values)) + +(defvar *shebang-readtable* + (let ((*readtable* (copy-readtable nil))) + (set-dispatch-macro-character #\# #\! + (lambda (s c n) (shebang-reader s c n)) + *readtable*) + *readtable*)) + +(defun shebang-readtable () + *shebang-readtable*) + +(defun sbcl-package-p (package) + (let ((name (package-name package))) + (eql (mismatch "SB-" name) 3))) + +(defun sbcl-source-file-p (filename) + (loop for (_ pattern) in (logical-pathname-translations "SYS") + thereis (pathname-match-p filename pattern))) + +(defun guess-readtable-for-filename (filename) + (if (sbcl-source-file-p filename) + (shebang-readtable) + *readtable*)) + +(defvar *debootstrap-packages* t) + +(defun call-with-debootstrapping (fun) + (handler-bind ((sb-int:bootstrap-package-not-found + #'sb-int:debootstrap-package)) + (funcall fun))) + +(defmacro with-debootstrapping (&body body) + `(call-with-debootstrapping (lambda () ,@body))) + +(defimplementation call-with-syntax-hooks (fn) + (cond ((and *debootstrap-packages* + (sbcl-package-p *package*)) + (with-debootstrapping (funcall fn))) + (t + (funcall fn)))) + +(defimplementation default-readtable-alist () + (let ((readtable (shebang-readtable))) + (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages)) + collect (cons (package-name p) readtable)))) + +;;; Utilities + +(defimplementation arglist (fname) + (sb-introspect:function-arglist fname)) + +(defimplementation function-name (f) + (check-type f function) + (sb-impl::%fun-name f)) + +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (flet ((ensure-list (thing) (if (listp thing) thing (list thing)))) + (let* ((flags (sb-cltl2:declaration-information decl-identifier))) + (if flags + ;; Symbols aren't printed with package qualifiers, but the FLAGS would + ;; have to be fully qualified when used inside a declaration. So we + ;; strip those as long as there's no better way. (FIXME) + `(&any ,@(remove-if-not #'(lambda (qualifier) + (find-symbol (symbol-name (first qualifier)) :cl)) + flags :key #'ensure-list)) + (call-next-method))))) + +(defvar *buffer-name* nil) +(defvar *buffer-offset*) +(defvar *buffer-substring* nil) + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning. +This traps all compiler conditions at a lower-level than using +C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to +craft our own error messages, which can omit a lot of redundant +information." + (let ((context (sb-c::find-error-context nil))) + (unless (eq condition *previous-compiler-condition*) + (setq *previous-compiler-condition* condition) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal (make-condition + 'compiler-condition + :original-condition condition + :severity (etypecase condition + (sb-c:compiler-error :error) + (sb-ext:compiler-note :note) + (style-warning :style-warning) + (warning :warning) + (error :error)) + :short-message (brief-compiler-message-for-emacs condition) + :references (condition-references (real-condition condition)) + :message (long-compiler-message-for-emacs condition context) + :location (compiler-note-location context)))) + +(defun real-condition (condition) + "Return the encapsulated condition or CONDITION itself." + (typecase condition + (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition)) + (t condition))) + +(defun condition-references (condition) + (if (typep condition 'sb-int:reference-condition) + (externalize-reference + (sb-int:reference-condition-references condition)))) + +(defun compiler-note-location (context) + (if context + (locate-compiler-note + (sb-c::compiler-error-context-file-name context) + (compiler-source-path context) + (sb-c::compiler-error-context-original-source context)) + (list :error "No error location available"))) + +(defun locate-compiler-note (file source-path source) + (cond ((and (not (eq file :lisp)) *buffer-name*) + ;; Compiling from a buffer + (let ((position (+ *buffer-offset* + (source-path-string-position + source-path *buffer-substring*)))) + (make-location (list :buffer *buffer-name*) + (list :position position)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (namestring file)) + (list :position + (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; Compiling macro generated code + (make-location (list :source-form source) + (list :position 1))) + (t + (error "unhandled case in compiler note ~S ~S ~S" file source-path source)))) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (let ((sb-int:*print-condition-references* nil)) + (princ-to-string condition))) + +(defun long-compiler-message-for-emacs (condition error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or sb-c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (sb-c::compiler-error-context-enclosing-source error-context) + (sb-c::compiler-error-context-source error-context))) + (let ((sb-int:*print-condition-references* nil)) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A" + enclosing source condition)))) + +(defun compiler-source-path (context) + "Return the source-path for the current compiler error. +Returns NIL if this cannot be determined by examining internal +compiler state." + (cond ((sb-c::node-p context) + (reverse + (sb-c::source-path-original-source + (sb-c::node-source-path context)))) + ((sb-c::compiler-error-context-p context) + (reverse + (sb-c::compiler-error-context-original-source-path context))))) + +(defimplementation call-with-compilation-hooks (function) + (declare (type function function)) + (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination) + (sb-c:compiler-error #'handle-notification-condition) + (sb-ext:compiler-note #'handle-notification-condition) + (style-warning #'handle-notification-condition) + (warning #'handle-notification-condition)) + (funcall function))) + +(defun handle-file-compiler-termination (condition) + "Handle a condition that caused the file compiler to terminate." + (handle-notification-condition + (sb-int:encapsulated-condition condition))) + +(defvar *trap-load-time-warnings* nil) + +(defimplementation swank-compile-file (filename load-p external-format) + (handler-case + (let ((output-file (with-compilation-hooks () + (compile-file filename + :external-format external-format)))) + (when output-file + ;; Cache the latest source file for definition-finding. + (source-cache-get filename (file-write-date filename)) + (when load-p + (load output-file)))) + (sb-c:fatal-compiler-error () nil))) + +;;;; compile-string + +;;; We copy the string to a temporary file in order to get adequate +;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms +;;; which the previous approach using +;;; (compile nil `(lambda () ,(read-from-string string))) +;;; did not provide. + +(sb-alien:define-alien-routine "tmpnam" sb-alien:c-string + (dest (* sb-alien:c-string))) + +(defun temp-file-name () + "Return a temporary file name to compile strings into." + (concatenate 'string (tmpnam nil) ".lisp")) + +(defimplementation swank-compile-string (string &key buffer position directory) + (let ((*buffer-name* buffer) + (*buffer-offset* position) + (*buffer-substring* string) + (filename (temp-file-name))) + (flet ((compile-it (fn) + (with-compilation-hooks () + (with-compilation-unit + (:source-plist (list :emacs-buffer buffer + :emacs-directory directory + :emacs-string string + :emacs-position position)) + (funcall fn (compile-file filename)))))) + (with-open-file (s filename :direction :output :if-exists :error) + (write-string string s)) + (unwind-protect + (if *trap-load-time-warnings* + (compile-it #'load) + (load (compile-it #'identity))) + (ignore-errors + (delete-file filename) + (delete-file (compile-file-pathname filename))))))) + +;;;; Definitions + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. +This is useful when debugging the definition-finding code.") + +(defparameter *definition-types* + '(:variable defvar + :constant defconstant + :type deftype + :symbol-macro define-symbol-macro + :macro defmacro + :compiler-macro define-compiler-macro + :function defun + :generic-function defgeneric + :method defmethod + :setf-expander define-setf-expander + :structure defstruct + :condition define-condition + :class defclass + :method-combination define-method-combination + :package defpackage + :transform :deftransform + :optimizer :defoptimizer + :vop :define-vop + :source-transform :define-source-transform) + "Map SB-INTROSPECT definition type names to Slime-friendly forms") + +(defimplementation find-definitions (name) + (loop for type in *definition-types* by #'cddr + for locations = (sb-introspect:find-definition-sources-by-name + name type) + append (loop for source-location in locations collect + (make-source-location-specification type name + source-location)))) + +(defun make-source-location-specification (type name source-location) + (list (list* (getf *definition-types* type) + name + (sb-introspect::definition-source-description source-location)) + (if *debug-definition-finding* + (make-definition-source-location source-location type name) + (handler-case + (make-definition-source-location source-location type name) + (error (e) + (list :error (format nil "Error: ~A" e))))))) + +(defun make-definition-source-location (definition-source type name) + (with-struct (sb-introspect::definition-source- + pathname form-path character-offset plist + file-write-date) + definition-source + (destructuring-bind (&key emacs-buffer emacs-position emacs-directory + emacs-string &allow-other-keys) + plist + (cond + (emacs-buffer + (let* ((*readtable* (guess-readtable-for-filename emacs-directory)) + (pos (if form-path + (with-debootstrapping + (source-path-string-position form-path emacs-string)) + character-offset)) + (snippet (string-path-snippet emacs-string form-path pos))) + (make-location `(:buffer ,emacs-buffer) + `(:position ,(+ pos emacs-position)) + `(:snippet ,snippet)))) + ((not pathname) + `(:error ,(format nil "Source of ~A ~A not found" + (string-downcase type) name))) + (t + (let* ((namestring (namestring (translate-logical-pathname pathname))) + (pos (source-file-position namestring file-write-date form-path + character-offset)) + (snippet (source-hint-snippet namestring file-write-date pos))) + (make-location `(:file ,namestring) + `(:position ,pos) + `(:snippet ,snippet)))))))) + +(defun string-path-snippet (string form-path position) + (if form-path + ;; If we have a form-path, use it to derive a more accurate + ;; snippet, so that we can point to the individual form rather + ;; than just the toplevel form. + (multiple-value-bind (data end) + (let ((*read-suppress* t)) + (read-from-string string nil nil :start position)) + (declare (ignore data)) + (subseq string position end)) + string)) + +(defun source-file-position (filename write-date form-path character-offset) + (let ((source (get-source-code filename write-date)) + (*readtable* (guess-readtable-for-filename filename))) + (1+ (with-debootstrapping + (if form-path + (source-path-string-position form-path source) + (or character-offset 0)))))) + +(defun source-hint-snippet (filename write-date position) + (let ((source (get-source-code filename write-date))) + (with-input-from-string (s source) + (read-snippet s position)))) + +(defun function-source-location (function &optional name) + (declare (type function function)) + (let ((location (sb-introspect:find-definition-source function))) + (make-definition-source-location location :function name))) + +(defun safe-function-source-location (fun name) + (if *debug-definition-finding* + (function-source-location fun name) + (handler-case (function-source-location fun name) + (error (e) + (list :error (format nil "Error: ~A" e)))))) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (sb-int:info :variable :kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (sb-int:info :setf :inverse symbol) + (sb-int:info :setf :expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (sb-int:info :type :kind symbol) + (doc 'type))) + result))) + +(defimplementation describe-definition (symbol type) + (case type + (:variable + (describe symbol)) + (:function + (describe (symbol-function symbol))) + (:setf + (describe (or (sb-int:info :setf :inverse symbol) + (sb-int:info :setf :expander symbol)))) + (:class + (describe (find-class symbol))) + (:type + (describe (sb-kernel:values-specifier-type symbol))))) + +#+#.(swank-backend::sbcl-with-xref-p) +(progn + (defmacro defxref (name) + `(defimplementation ,name (what) + (sanitize-xrefs + (mapcar #'source-location-for-xref-data + (,(find-symbol (symbol-name name) "SB-INTROSPECT") + what))))) + (defxref who-calls) + (defxref who-binds) + (defxref who-sets) + (defxref who-references) + (defxref who-macroexpands)) + +(defun source-location-for-xref-data (xref-data) + (let ((name (car xref-data)) + (source-location (cdr xref-data))) + (list name + (handler-case (make-definition-source-location source-location + 'function + name) + (error (e) + (list :error (format nil "Error: ~A" e))))))) + +(defimplementation list-callers (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))) + +(defimplementation list-callees (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))) + +(defun sanitize-xrefs (xrefs) + (remove-duplicates + (remove-if (lambda (f) + (member f (ignored-xref-function-names))) + (loop for entry in xrefs + for name = (car entry) + collect (if (and (consp name) + (member (car name) + '(sb-pcl::fast-method + sb-pcl::slow-method + sb-pcl::method))) + (cons (cons 'defmethod (cdr name)) + (cdr entry)) + entry)) + :key #'car) + :test (lambda (a b) + (and (eq (first a) (first b)) + (equal (second a) (second b)))))) + +(defun ignored-xref-function-names () + #-#.(swank-backend::sbcl-with-new-stepper-p) + '(nil sb-c::step-form sb-c::step-values) + #+#.(swank-backend::sbcl-with-new-stepper-p) + '(nil)) + +(defun function-dspec (fn) + "Describe where the function FN was defined. +Return a list of the form (NAME LOCATION)." + (let ((name (sb-kernel:%fun-name fn))) + (list name (safe-function-source-location fn name)))) + +;;; macroexpansion + +(defimplementation macroexpand-all (form) + (let ((sb-walker:*walk-form-expand-macros-p* t)) + (sb-walker:walk-form form))) + + +;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation install-debugger-globally (function) + (setq sb-ext:*invoke-debugger-hook* function)) + +(defimplementation condition-extras (condition) + (cond #+#.(swank-backend::sbcl-with-new-stepper-p) + ((typep condition 'sb-impl::step-form-condition) + `((:show-frame-source 0))) + ((typep condition 'sb-int:reference-condition) + (let ((refs (sb-int:reference-condition-references condition))) + (if refs + `((:references ,(externalize-reference refs)))))))) + +(defun externalize-reference (ref) + (etypecase ref + (null nil) + (cons (cons (externalize-reference (car ref)) + (externalize-reference (cdr ref)))) + ((or string number) ref) + (symbol + (cond ((eq (symbol-package ref) (symbol-package :test)) + ref) + (t (symbol-name ref)))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame))) + (sb-debug:*stack-top-hint* nil)) + (handler-bind ((sb-di:debug-condition + (lambda (condition) + (signal (make-condition + 'sldb-condition + :original-condition condition))))) + (funcall debugger-loop-fn)))) + +#+#.(swank-backend::sbcl-with-new-stepper-p) +(progn + (defimplementation activate-stepping (frame) + (declare (ignore frame)) + (sb-impl::enable-stepping)) + (defimplementation sldb-stepper-condition-p (condition) + (typep condition 'sb-ext:step-form-condition)) + (defimplementation sldb-step-into () + (invoke-restart 'sb-ext:step-into)) + (defimplementation sldb-step-next () + (invoke-restart 'sb-ext:step-next)) + (defimplementation sldb-step-out () + (invoke-restart 'sb-ext:step-out))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((sb-ext:*invoke-debugger-hook* hook) + #+#.(swank-backend::sbcl-with-new-stepper-p) + (sb-ext:*stepper-hook* + (lambda (condition) + (typecase condition + (sb-ext:step-form-condition + (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame))) + (sb-impl::invoke-debugger condition))))))) + (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p) + (sb-ext:step-condition #'sb-impl::invoke-stepper)) + (funcall fun)))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (sb-di:frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + "Return a list of frames starting with frame number START and +continuing to frame number END or, if END is nil, the last frame on the +stack." + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (sb-di:frame-down f) + for i from start below end + while f + collect f))) + +(defimplementation print-frame (frame stream) + (sb-debug::print-frame-call frame stream)) + +;;;; Code-location -> source-location translation + +;;; If debug-block info is avaibale, we determine the file position of +;;; the source-path for a code-location. If the code was compiled +;;; with C-c C-c, we have to search the position in the source string. +;;; If there's no debug-block info, we return the (less precise) +;;; source-location of the corresponding function. + +(defun code-location-source-location (code-location) + (let* ((dsource (sb-di:code-location-debug-source code-location)) + (plist (sb-c::debug-source-plist dsource))) + (if (getf plist :emacs-buffer) + (emacs-buffer-source-location code-location plist) + (ecase (sb-di:debug-source-from dsource) + (:file (file-source-location code-location)) + (:lisp (lisp-source-location code-location)))))) + +;;; FIXME: The naming policy of source-location functions is a bit +;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the +;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co +;;; which returns the source location for a _code-location_. +;;; +;;; Maybe these should be named code-location-file-source-location, +;;; etc, turned into generic functions, or something. In the very +;;; least the names should indicate the main entry point vs. helper +;;; status. + +(defun file-source-location (code-location) + (if (code-location-has-debug-block-info-p code-location) + (source-file-source-location code-location) + (fallback-source-location code-location))) + +(defun fallback-source-location (code-location) + (let ((fun (code-location-debug-fun-fun code-location))) + (cond (fun (function-source-location fun)) + (t (error "Cannot find source location for: ~A " code-location))))) + +(defun lisp-source-location (code-location) + (let ((source (prin1-to-string + (sb-debug::code-location-source-form code-location 100)))) + (make-location `(:source-form ,source) '(:position 0)))) + +(defun emacs-buffer-source-location (code-location plist) + (if (code-location-has-debug-block-info-p code-location) + (destructuring-bind (&key emacs-buffer emacs-position emacs-string + &allow-other-keys) + plist + (let* ((pos (string-source-position code-location emacs-string)) + (snipped (with-input-from-string (s emacs-string) + (read-snippet s pos)))) + (make-location `(:buffer ,emacs-buffer) + `(:position ,(+ emacs-position pos)) + `(:snippet ,snipped)))) + (fallback-source-location code-location))) + +(defun source-file-source-location (code-location) + (let* ((code-date (code-location-debug-source-created code-location)) + (filename (code-location-debug-source-name code-location)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (let* ((pos (stream-source-position code-location s)) + (snippet (read-snippet s pos))) + (make-location `(:file ,filename) + `(:position ,(1+ pos)) + `(:snippet ,snippet)))))) + +(defun code-location-debug-source-name (code-location) + (sb-c::debug-source-name (sb-di::code-location-debug-source code-location))) + +(defun code-location-debug-source-created (code-location) + (sb-c::debug-source-created + (sb-di::code-location-debug-source code-location))) + +(defun code-location-debug-fun-fun (code-location) + (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location))) + +(defun code-location-has-debug-block-info-p (code-location) + (handler-case + (progn (sb-di:code-location-debug-block code-location) + t) + (sb-di:no-debug-blocks () nil))) + +(defun stream-source-position (code-location stream) + (let* ((cloc (sb-debug::maybe-block-start-location code-location)) + (tlf-number (sb-di::code-location-toplevel-form-offset cloc)) + (form-number (sb-di::code-location-form-number cloc))) + (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) + (let* ((path-table (sb-di::form-number-translations tlf 0)) + (path (cond ((<= (length path-table) form-number) + (warn "inconsistent form-number-translations") + (list 0)) + (t + (reverse (cdr (aref path-table form-number))))))) + (source-path-source-position path tlf pos-map))))) + +(defun string-source-position (code-location string) + (with-input-from-string (s string) + (stream-source-position code-location s))) + +;;; source-path-file-position and friends are in swank-source-path-parser + +(defun safe-source-location-for-emacs (code-location) + (if *debug-definition-finding* + (code-location-source-location code-location) + (handler-case (code-location-source-location code-location) + (error (c) (list :error (format nil "~A" c)))))) + +(defimplementation frame-source-location-for-emacs (index) + (safe-source-location-for-emacs + (sb-di:frame-code-location (nth-frame index)))) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))) + +(defun debug-var-value (var frame location) + (ecase (sb-di:debug-var-validity var location) + (:valid (sb-di:debug-var-value var frame)) + ((:invalid :unknown) ':<not-available>))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (sb-di:frame-code-location frame)) + (vars (frame-debug-vars frame))) + (loop for v across vars collect + (list :name (sb-di:debug-var-symbol v) + :id (sb-di:debug-var-id v) + :value (debug-var-value v frame loc))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame (sb-di:frame-code-location frame)))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (sb-di:frame-catches (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (let ((frame (nth-frame index))) + (funcall (the function + (sb-di:preprocess-for-eval form + (sb-di:frame-code-location frame))) + frame))) + +#+#.(swank-backend::sbcl-with-restart-frame) +(progn + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index))) + (cond ((sb-debug:frame-has-debug-tag-p frame) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (sb-debug:unwind-to-frame-and-call frame + (lambda () + (values-list values))))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let* ((frame (nth-frame index))) + (cond ((sb-debug:frame-has-debug-tag-p frame) + (let* ((call-list (sb-debug::frame-call-as-list frame)) + (fun (fdefinition (car call-list))) + (thunk (lambda () + ;; Ensure that the thunk gets tail-call-optimized + (declare (optimize (debug 1))) + (apply fun (cdr call-list))))) + (sb-debug:unwind-to-frame-and-call frame thunk))) + (t (format nil "Cannot restart frame: ~S" frame)))))) + +;; FIXME: this implementation doesn't unwind the stack before +;; re-invoking the function, but it's better than no implementation at +;; all. +#-#.(swank-backend::sbcl-with-restart-frame) +(progn + (defun sb-debug-catch-tag-p (tag) + (and (symbolp tag) + (not (symbol-package tag)) + (string= tag :sb-debug-catch-tag))) + + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index)) + (probe (assoc-if #'sb-debug-catch-tag-p + (sb-di::frame-catches frame)))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let ((frame (nth-frame index))) + (return-from-frame index (sb-debug::frame-call-as-list frame))))) + +;;;;; reference-conditions + +(defimplementation format-sldb-condition (condition) + (let ((sb-int:*print-condition-references* nil)) + (princ-to-string condition))) + + +;;;; Profiling + +(defimplementation profile (fname) + (when fname (eval `(sb-profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(sb-profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (sb-profile:unprofile) + "All functions unprofiled.") + +(defimplementation profile-report () + (sb-profile:report)) + +(defimplementation profile-reset () + (sb-profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (sb-profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(sb-profile:profile ,(package-name (find-package package))))) + + +;;;; Inspector + +(defclass sbcl-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'sbcl-inspector)) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (declare (ignore inspector)) + (cond ((sb-di::indirect-value-cell-p o) + (values "A value cell." (label-value-line* + (:value (sb-kernel:value-cell-ref o))))) + (t + (multiple-value-bind (text label parts) (sb-impl::inspected-parts o) + (if label + (values text (loop for (l . v) in parts + append (label-value-line l v))) + (values text (loop for value in parts for i from 0 + append (label-value-line i value)))))))) + +(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) + (declare (ignore inspector)) + (let ((header (sb-kernel:widetag-of o))) + (cond ((= header sb-vm:simple-fun-header-widetag) + (values "A simple-fun." + (label-value-line* + (:name (sb-kernel:%simple-fun-name o)) + (:arglist (sb-kernel:%simple-fun-arglist o)) + (:self (sb-kernel:%simple-fun-self o)) + (:next (sb-kernel:%simple-fun-next o)) + (:type (sb-kernel:%simple-fun-type o)) + (:code (sb-kernel:fun-code-header o))))) + ((= header sb-vm:closure-header-widetag) + (values "A closure." + (append + (label-value-line :function (sb-kernel:%closure-fun o)) + `("Closed over values:" (:newline)) + (loop for i below (1- (sb-kernel:get-closure-length o)) + append (label-value-line + i (sb-kernel:%closure-index-ref o i)))))) + (t (call-next-method o))))) + +(defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ backend-inspector)) + (declare (ignore _)) + (values (format nil "~A is a code data-block." o) + (append + (label-value-line* + (:code-size (sb-kernel:%code-code-size o)) + (:entry-points (sb-kernel:%code-entry-points o)) + (:debug-info (sb-kernel:%code-debug-info o)) + (:trace-table-offset (sb-kernel:code-header-ref + o sb-vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from sb-vm:code-constants-offset + below (sb-kernel:get-header-data o) + append (label-value-line i (sb-kernel:code-header-ref o i))) + `("Code:" (:newline) + , (with-output-to-string (s) + (cond ((sb-kernel:%code-debug-info o) + (sb-disassem:disassemble-code-component o :stream s)) + (t + (sb-disassem:disassemble-memory + (sb-disassem::align + (+ (logandc2 (sb-kernel:get-lisp-obj-address o) + sb-vm:lowtag-mask) + (* sb-vm:code-constants-offset + sb-vm:n-word-bytes)) + (ash 1 sb-vm:n-lowtag-bits)) + (ash (sb-kernel:%code-code-size o) sb-vm:word-shift) + :stream s)))))))) + +(defmethod inspect-for-emacs ((o sb-ext:weak-pointer) (inspector backend-inspector)) + (declare (ignore inspector)) + (values "A weak pointer." + (label-value-line* + (:value (sb-ext:weak-pointer-value o))))) + +(defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector backend-inspector)) + (declare (ignore inspector)) + (values "A fdefn object." + (label-value-line* + (:name (sb-kernel:fdefn-name o)) + (:function (sb-kernel:fdefn-fun o))))) + +(defmethod inspect-for-emacs :around ((o generic-function) + (inspector backend-inspector)) + (declare (ignore inspector)) + (multiple-value-bind (title contents) (call-next-method) + (values title + (append + contents + (label-value-line* + (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o)) + (:initial-methods (sb-pcl::generic-function-initial-methods o)) + ))))) + + +;;;; Multiprocessing + +#+(and sb-thread + #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or))) +(progn + (defvar *thread-id-counter* 0) + + (defvar *thread-id-counter-lock* + (sb-thread:make-mutex :name "thread id counter lock")) + + (defun next-thread-id () + (sb-thread:with-mutex (*thread-id-counter-lock*) + (incf *thread-id-counter*))) + + (defparameter *thread-id-map* (make-hash-table)) + + ;; This should be a thread -> id map but as weak keys are not + ;; supported it is id -> map instead. + (defvar *thread-id-map-lock* + (sb-thread:make-mutex :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (sb-thread:make-thread fn :name name)) + + (defimplementation thread-id (thread) + (block thread-id + (sb-thread:with-mutex (*thread-id-map-lock*) + (loop for id being the hash-key in *thread-id-map* + using (hash-value thread-pointer) + do + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (cond ((null maybe-thread) + ;; the value is gc'd, remove it manually + (remhash id *thread-id-map*)) + ((eq thread maybe-thread) + (return-from thread-id id))))) + ;; lazy numbering + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread)) + id)))) + + (defimplementation find-thread (id) + (sb-thread:with-mutex (*thread-id-map-lock*) + (let ((thread-pointer (gethash id *thread-id-map*))) + (if thread-pointer + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (if maybe-thread + maybe-thread + ;; the value is gc'd, remove it manually + (progn + (remhash id *thread-id-map*) + nil))) + nil)))) + + (defimplementation thread-name (thread) + ;; sometimes the name is not a string (e.g. NIL) + (princ-to-string (sb-thread:thread-name thread))) + + (defimplementation thread-status (thread) + (if (sb-thread:thread-alive-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (sb-thread:make-mutex :name name)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (sb-thread:with-mutex (lock) (funcall function))) + + (defimplementation make-recursive-lock (&key name) + (sb-thread:make-mutex :name name)) + + (defimplementation call-with-recursive-lock-held (lock function) + (declare (type function function)) + (sb-thread:with-recursive-lock (lock) (funcall function))) + + (defimplementation current-thread () + sb-thread:*current-thread*) + + (defimplementation all-threads () + (sb-thread:list-all-threads)) + + (defimplementation interrupt-thread (thread fn) + (sb-thread:interrupt-thread thread fn)) + + (defimplementation kill-thread (thread) + (sb-thread:terminate-thread thread)) + + (defimplementation thread-alive-p (thread) + (sb-thread:thread-alive-p thread)) + + (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (sb-thread:make-mutex)) + (waitqueue (sb-thread:make-waitqueue)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (sb-thread:with-mutex (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-mutex (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation receive () + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-mutex (mutex) + (loop + (let ((q (mailbox.queue mbox))) + (cond (q (return (pop (mailbox.queue mbox)))) + (t (sb-thread:condition-wait (mailbox.waitqueue mbox) + mutex)))))))) + + + ;; Auto-flush streams + + (defvar *auto-flush-interval* 0.15 + "How often to flush interactive streams. This valu is passed + directly to cl:sleep.") + + (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush")) + + (defvar *auto-flush-thread* nil) + + (defvar *auto-flush-streams* '()) + + (defimplementation make-stream-interactive (stream) + (call-with-recursive-lock-held + *auto-flush-lock* + (lambda () + (pushnew stream *auto-flush-streams*) + (unless *auto-flush-thread* + (setq *auto-flush-thread* + (sb-thread:make-thread #'flush-streams + :name "auto-flush-thread")))))) + + (defun flush-streams () + (loop + (call-with-recursive-lock-held + *auto-flush-lock* + (lambda () + (setq *auto-flush-streams* + (remove-if (lambda (x) + (not (and (open-stream-p x) + (output-stream-p x)))) + *auto-flush-streams*)) + (mapc #'finish-output *auto-flush-streams*))) + (sleep *auto-flush-interval*))) + + ) + +(defimplementation quit-lisp () + #+sb-thread + (dolist (thread (remove (current-thread) (all-threads))) + (ignore-errors (sb-thread:interrupt-thread + thread (lambda () (sb-ext:quit :recklessly-p t))))) + (sb-ext:quit)) + + + +;;Trace implementations +;;In SBCL, we have: +;; (trace <name>) +;; (trace :methods '<name>) ;to trace all methods of the gf <name> +;; (trace (method <name> <qualifier>? (<specializer>+))) +;; <name> can be a normal name or a (setf name) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((member fspec (eval '(trace)) :test #'equal) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args)) + (format nil "~S is now traced." fspec)))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defmethod) + (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec))))) + ((:defgeneric) + (toggle-trace-aux (second spec) :methods t)) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee :wherein (list (process-fspec caller))))))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + #+#.(swank-backend::sbcl-with-weak-hash-tables) + (apply #'make-hash-table :weakness :key args) + #-#.(swank-backend::sbcl-with-weak-hash-tables) + (apply #'make-hash-table args)) + +(defimplementation make-weak-value-hash-table (&rest args) + #+#.(swank-backend::sbcl-with-weak-hash-tables) + (apply #'make-hash-table :weakness :value args) + #-#.(swank-backend::sbcl-with-weak-hash-tables) + (apply #'make-hash-table args)) + +(defimplementation hash-table-weakness (hashtable) + #+#.(swank-backend::sbcl-with-weak-hash-tables) + (sb-ext:hash-table-weakness hashtable)) Added: branches/trunk-reorg/thirdparty/slime/swank-scl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-scl.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-scl.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,2070 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; Scieneer Common Lisp code for SLIME. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package :swank-backend) + + + +;;; swank-mop + +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; TCP server +;;; +;;; SCL only supports the :spawn communication style. +;;; + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port) + (let ((addr (resolve-hostname host))) + (ext:create-inet-listener port :stream :host addr :reuse-address t))) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (ext:close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (let ((external-format (or external-format :default)) + (buffering (or buffering :full)) + (fd (socket-fd socket))) + (loop + (let ((ready (sys:wait-until-fd-usable fd :input timeout))) + (unless ready + (error "Timeout accepting connection on socket: ~S~%" socket))) + (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd)))) + (when new-fd + (return (make-socket-io-stream new-fd external-format buffering))))))) + +(defimplementation set-stream-timeout (stream timeout) + (check-type timeout (or null real)) + (if (fboundp 'ext::stream-timeout) + (setf (ext::stream-timeout stream) timeout) + (setf (slot-value (slot-value stream 'cl::stream) 'cl::timeout) timeout))) + +;;;;; Sockets + +(defun socket-fd (socket) + "Return the file descriptor for the socket represented by 'socket." + (etypecase socket + (fixnum socket) + (stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of 'hostname as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (fd external-format buffering) + "Create a new input/output fd-stream for 'fd." + (let* ((stream (sys:make-fd-stream fd :input t :output t + :element-type 'base-char + :buffering buffering + :external-format external-format))) + ;; Ignore character conversion errors. Without this the communication + ;; channel is prone to lockup if a character conversion error occurs. + (setf (cl::stream-character-conversion-error-value stream) #\?) + stream)) + + +;;;; Stream handling + +(defclass slime-input-stream (ext:character-input-stream) + ((buffer :initarg :buffer :type string) + (index :initarg :index :initform 0 :type fixnum) + (position :initarg :position :initform 0 :type integer) + (interactive :initarg :interactive :initform nil :type (member nil t)) + (output-stream :initarg :output-stream :initform nil) + (input-fn :initarg :input-fn :type function) + )) + +(defun make-slime-input-stream (input-fn &optional output-stream) + (declare (function input-fn)) + (make-instance 'slime-input-stream + :in-buffer (make-string 256) + :in-head 0 :in-tail 0 + :out-buffer "" + :buffer "" :index 0 + :input-fn input-fn + :output-stream output-stream)) + +(defmethod print-object ((s slime-input-stream) stream) + (print-unreadable-object (s stream :type t))) + +;;; input-stream-p inherits from input-stream. +;;; output-stream-p inherits nil. + +(defmethod ext:stream-listen ((stream slime-input-stream)) + (let* ((buffer (slot-value stream 'buffer)) + (index (slot-value stream 'index)) + (length (length buffer))) + (declare (type string buffer) + (fixnum index length)) + (< index length))) + +(defmethod close ((stream slime-input-stream) &key ((:abort abort) nil)) + (declare (ignore abort)) + (when (ext:stream-open-p stream) + (setf (ext:stream-open-p stream) nil) + (setf (ext:stream-in-buffer stream) " ") + t)) + +(defmethod ext:stream-clear-input ((stream slime-input-stream)) + (let* ((input-buffer (slot-value stream 'buffer)) + (index (slot-value stream 'index)) + (input-length (length input-buffer)) + (available (- input-length index)) + (position (slot-value stream 'position)) + (new-position (+ position available))) + (declare (type kernel:index index available position new-position)) + (setf (slot-value stream 'position) new-position)) + (setf (slot-value stream 'buffer) "") + (setf (slot-value stream 'index) 0) + nil) + +;;; No 'stream-finish-output method. +;;; No 'stream-force-output method. +;;; No 'stream-clear-output method. + +;;; stream-element-type inherits from character-stream. + +;;; No 'stream-line-length method. +;;; No 'stream-line-column method. + +;;; Add the remaining input to the current position. +(defmethod file-length ((stream slime-input-stream)) + (let* ((input-buffer (slot-value stream 'buffer)) + (index (slot-value stream 'index)) + (input-length (length input-buffer)) + (available (- input-length index)) + (position (slot-value stream 'position)) + (file-length (+ position available))) + (declare (type kernel:index index available position file-length)) + file-length)) + +(defmethod ext:stream-file-position ((stream slime-input-stream) + &optional position) + (let ((current-position (slot-value stream 'position))) + (declare (type kernel:index current-position)) + (cond (position + ;; Could make an attempt here, but just give up for now. + nil) + (t + current-position)))) + +(defmethod interactive-stream-p ((stream slime-input-stream)) + (slot-value stream 'interactive)) + +;;; No 'file-string-length method. + +(defmethod ext:stream-read-chars ((stream slime-input-stream) buffer + start requested waitp) + (declare (type simple-string buffer) + (type kernel:index start requested)) + (let* ((input-buffer (slot-value stream 'buffer)) + (index (slot-value stream 'index)) + (input-length (length input-buffer)) + (available (- input-length index)) + (copy (min available requested))) + (declare (string input-buffer) + (type kernel:index index available copy)) + (cond ((plusp copy) + (dotimes (i copy) + (declare (type kernel:index i)) + (setf (aref buffer (+ start i)) (aref input-buffer (+ index i)))) + (setf (slot-value stream 'index) (+ index copy)) + (incf (slot-value stream 'position) copy) + copy) + (waitp + (let ((output-stream (slot-value stream 'output-stream)) + (input-fn (slot-value stream 'input-fn))) + (declare (type function input-fn)) + (when output-stream + (force-output output-stream)) + (let ((new-input (funcall input-fn))) + (cond ((zerop (length new-input)) + -1) + (t + (setf (slot-value stream 'buffer) new-input) + (setf (slot-value stream 'index) 0) + (ext:stream-read-chars stream buffer + start requested waitp)))))) + (t + 0)))) + +;;; Slime output stream. + +(defclass slime-output-stream (ext:character-output-stream) + ((output-fn :initarg :output-fn :type function) + (column :initform 0 :type kernel:index) + (interactive :initform nil :type (member nil t)) + (position :initform 0 :type integer))) + +(defun make-slime-output-stream (output-fn) + (declare (function output-fn)) + (make-instance 'slime-output-stream + :in-buffer "" + :out-buffer (make-string 256) + :output-fn output-fn)) + +(defmethod print-object ((s slime-output-stream) stream) + (print-unreadable-object (s stream :type t))) + +;;; Use default 'input-stream-p method for 'output-stream which returns 'nil. +;;; Use default 'output-stream-p method for 'output-stream which returns 't. + +;;; No 'stream-listen method. + +(defmethod close ((stream slime-output-stream) &key ((:abort abort) nil)) + (when (ext:stream-open-p stream) + (unless abort + (finish-output stream)) + (setf (ext:stream-open-p stream) nil) + (setf (ext:stream-out-buffer stream) " ") + t)) + +;;; No 'stream-clear-input method. + +(defmethod ext:stream-finish-output ((stream slime-output-stream)) + nil) + +(defmethod ext:stream-force-output ((stream slime-output-stream)) + nil) + +(defmethod ext:stream-clear-output ((stream slime-output-stream)) + nil) + +;;; Use default 'stream-element-type method for 'character-stream which +;;; returns 'base-char. + +(defmethod ext:stream-line-length ((stream slime-output-stream)) + 80) + +(defmethod ext:stream-line-column ((stream slime-output-stream)) + (slot-value stream 'column)) + +(defmethod file-length ((stream slime-output-stream)) + (slot-value stream 'position)) + +(defmethod ext:stream-file-position ((stream slime-output-stream) + &optional position) + (declare (optimize (speed 3))) + (cond (position + (let* ((current-position (slot-value stream 'position)) + (target-position (etypecase position + ((member :start) 0) + ((member :end) current-position) + (kernel:index position)))) + (declare (type kernel:index current-position target-position)) + (cond ((= target-position current-position) + t) + ((> target-position current-position) + (let ((output-fn (slot-value stream 'output-fn)) + (fill-size (- target-position current-position))) + (declare (function output-fn)) + (funcall output-fn (make-string fill-size + :initial-element #\space)) + (setf (slot-value stream 'position) target-position)) + t) + (t + nil)))) + (t + (slot-value stream 'position)))) + +(defmethod interactive-stream-p ((stream slime-output-stream)) + (slot-value stream 'interactive)) + +;;; Use the default 'character-output-stream 'file-string-length method. + +;;; stream-write-chars +;;; +;;; The stream out-buffer is typically large enough that there is little point +;;; growing the stream output 'string large than the total size. For typical +;;; usage this reduces consing. As the string grows larger then grow to +;;; reduce the cost of copying strings around. +;;; +(defmethod ext:stream-write-chars ((stream slime-output-stream) + string start end waitp) + (declare (simple-string string) + (type kernel:index start end) + (ignore waitp)) + (declare (optimize (speed 3))) + (unless (ext:stream-open-p stream) + (error 'kernel:simple-stream-error + :stream stream + :format-control "Stream closed.")) + (let* ((string-length (length string)) + (start (cond ((< start 0) 0) + ((> start string-length) string-length) + (t start))) + (end (cond ((< end start) start) + ((> end string-length) string-length) + (t end))) + (length (- end start)) + (output-fn (slot-value stream 'output-fn))) + (declare (type kernel:index start end length) + (type function output-fn)) + (unless (zerop length) + (funcall output-fn (subseq string start end)) + (let ((last-newline (position #\newline string :from-end t + :start start :end end))) + (setf (slot-value stream 'column) + (if last-newline + (- end last-newline 1) + (let ((column (slot-value stream 'column))) + (declare (type kernel:index column)) + (+ column (- end start)))))))) + (- end start)) + +;;; + +(defimplementation make-fn-streams (input-fn output-fn) + (let* ((output (make-slime-output-stream output-fn)) + (input (make-slime-input-stream input-fn output))) + (values input output))) + +(defimplementation make-stream-interactive (stream) + (when (or (typep stream 'slime-input-stream) + (typep stream 'slime-output-stream)) + (setf (slot-value stream 'interactive) t))) + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. + Nil if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation swank-compile-file (filename load-p external-format) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (ext:*ignore-extra-close-parentheses* nil)) + (multiple-value-bind (output-file warnings-p failure-p) + (compile-file filename :external-format external-format) + (unless failure-p + ;; Cache the latest source file for definition-finding. + (source-cache-get filename (file-write-date filename)) + (when load-p (load output-file))) + (values output-file warnings-p failure-p))))) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string)) + (with-input-from-string (stream string) + (ext:compile-from-stream + stream + :source-info `(:emacs-buffer ,buffer + :emacs-buffer-offset ,position + :emacs-buffer-string ,string)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `swank:compiler-condition's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal (make-condition + 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :short-message (brief-compiler-message-for-emacs condition) + :message (long-compiler-message-for-emacs condition context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context))))) + +(defun severity-for-emacs (condition) + "Return the severity of 'condition." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. + When Emacs presents the message it already has the source popped up + and the source form highlighted. This makes much of the information in + the error-context redundant." + (princ-to-string condition)) + +(defun long-compiler-message-for-emacs (condition error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A" + enclosing source condition))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :position (+ *buffer-start-position* pos)))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. + Return a `location' record, or (:error <reason>) on failure." + (if (null context) + (note-error-location) + (let ((file (c::compiler-error-context-file-name context)) + (source (c::compiler-error-context-original-source context)) + (path + (reverse (c::compiler-error-context-original-source-path context)))) + (or (locate-compiler-note file source path) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (list :error "No error location available.")) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (let ((position (+ *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + (make-location (list :buffer *buffer-name*) + (list :position position)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position + (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + + +;;; TODO +(defimplementation who-calls (name) nil) +(defimplementation who-references (name) nil) +(defimplementation who-binds (name) nil) +(defimplementation who-sets (name) nil) +(defimplementation who-specializes (symbol) nil) +(defimplementation who-macroexpands (name) nil) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(declaim (inline map-code-constants)) +(defun map-code-constants (code fn) + "Call 'fn for each constant in 'code's constant pool." + (check-type code kernel:code-component) + (loop for i from vm:code-constants-offset below (kernel:get-header-data code) + do (funcall fn (kernel:code-header-ref code i)))) + +(defun function-callees (function) + "Return 'function's callees as a list of functions." + (let ((callees '())) + (map-code-constants + (vm::find-code-object function) + (lambda (obj) + (when (kernel:fdefn-p obj) + (push (kernel:fdefn-function obj) callees)))) + callees)) + +(declaim (ext:maybe-inline map-allocated-code-components)) +(defun map-allocated-code-components (spaces fn) + "Call FN for each allocated code component in one of 'spaces. FN + receives the object as argument. 'spaces should be a list of the + symbols :dynamic, :static, or :read-only." + (dolist (space spaces) + (declare (inline vm::map-allocated-objects) + (optimize (ext:inhibit-warnings 3))) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum size) (ignore size)) + (when (= vm:code-header-type header) + (funcall fn obj))) + space))) + +(declaim (ext:maybe-inline map-caller-code-components)) +(defun map-caller-code-components (function spaces fn) + "Call 'fn for each code component with a fdefn for 'function in its + constant pool." + (let ((function (coerce function 'function))) + (declare (inline map-allocated-code-components)) + (map-allocated-code-components + spaces + (lambda (obj) + (map-code-constants + obj + (lambda (constant) + (when (and (kernel:fdefn-p constant) + (eq (kernel:fdefn-function constant) + function)) + (funcall fn obj)))))))) + +(defun function-callers (function &optional (spaces '(:read-only :static + :dynamic))) + "Return 'function's callers. The result is a list of code-objects." + (let ((referrers '())) + (declare (inline map-caller-code-components)) + (map-caller-code-components function spaces + (lambda (code) (push code referrers))) + referrers)) + +(defun debug-info-definitions (debug-info) + "Return the defintions for a debug-info. This should only be used + for code-object without entry points, i.e., byte compiled + code (are theree others?)" + ;; This mess has only been tested with #'ext::skip-whitespace, a + ;; byte-compiled caller of #'read-char . + (check-type debug-info (and (not c::compiled-debug-info) c::debug-info)) + (let ((name (c::debug-info-name debug-info)) + (source (c::debug-info-source debug-info))) + (destructuring-bind (first) source + (ecase (c::debug-source-from first) + (:file + (list (list name + (make-location + (list :file (unix-truename (c::debug-source-name first))) + (list :function-name (string name)))))))))) + +(defun valid-function-name-p (name) + (or (symbolp name) (and (consp name) + (eq (car name) 'setf) + (symbolp (cadr name)) + (not (cddr name))))) + +(defun code-component-entry-points (code) + "Return a list ((name location) ...) of function definitons for + the code omponent 'code." + (let ((names '())) + (do ((f (kernel:%code-entry-points code) (kernel::%function-next f))) + ((not f)) + (let ((name (kernel:%function-name f))) + (when (valid-function-name-p name) + (push (list name (function-location f)) names)))) + names)) + +(defimplementation list-callers (symbol) + "Return a list ((name location) ...) of callers." + (let ((components (function-callers symbol)) + (xrefs '())) + (dolist (code components) + (let* ((entry (kernel:%code-entry-points code)) + (defs (if entry + (code-component-entry-points code) + ;; byte compiled stuff + (debug-info-definitions + (kernel:%code-debug-info code))))) + (setq xrefs (nconc defs xrefs)))) + xrefs)) + +(defimplementation list-callees (symbol) + (let ((fns (function-callees symbol))) + (mapcar (lambda (fn) + (list (kernel:%function-name fn) + (function-location fn))) + fns))) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the SCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `swank-source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. + This is useful when debugging the definition-finding code.") + +(defvar *source-snippet-size* 256 + "Maximum number of characters in a snippet of source code. + Snippets at the beginning of definitions are used to tell Emacs what + the definitions looks like, so that it can accurately find them by + text search.") + +(defmacro safe-definition-finding (&body body) + "Execute 'body and return the source-location it returns. + If an error occurs and `*debug-definition-finding*' is false, then + return an error pseudo-location. + + The second return value is 'nil if no error occurs, otherwise it is the + condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values (list :error (princ-to-string c)) c)))))) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for 'code-location." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for 'code-location in 'filename." + (let* ((code-date (di:debug-source-created debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a 'code-location from a stream. + This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLIME stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :position (+ (getf info :emacs-buffer-offset) position)) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for 'debug-info. + Function-name source-locations are a fallback for when precise + positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of 'debug-source contain an Emacs buffer location? + This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream) + "Return the byte offset of 'code-location in 'stream. Extract the + toplevel-form-number and form-number from 'code-location and use that + to find the position of the corresponding form. + + Finish with 'stream positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (di:code-location-top-level-form-offset location)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in 'stream. + 'tlf-number is the top-level-form number. + 'form-number is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of 'code-location in 'string. + See 'code-location-stream-position." + (with-input-from-string (s string) + (code-location-stream-position code-location s))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name))) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; SCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the SCL manual for more details. + +(defun function-definitions (name) + "Return definitions for 'name in the \"function namespace\", i.e., + regular functions, generic functions, methods and macros. + 'name can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (special? (and (symbolp name) (special-operator-p name))) + (function? (and (valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (special? + (list `((:special-operator ,name) + (:error ,(format nil "Special operator: ~S" name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (generic-function-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for 'function." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + + +(defun byte-function-location (fn) + "Return the location of the byte-compiled function 'fn." + (etypecase fn + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((component (c::byte-function-component fn)) + (debug-info (kernel:%code-debug-info component))) + (debug-info-function-name-location debug-info))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fn))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in SCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is 'function a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that 'function belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + ;; Find the location in a constructor. + (function-location (struct-constructor dd))) + +(defun struct-constructor (dd) + "Return a constructor function from a defstruct definition. +Signal an error if no constructor can be found." + (let ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (when (or (null constructor) + (and (consp constructor) (null (car constructor)))) + (error "Cannot find structure's constructor: ~S" + (kernel::dd-name dd))) + (coerce (if (consp constructor) (first constructor) constructor) + 'function))) + +;;;;;; Generic functions and methods + +(defun generic-function-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (clos:generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (clos:generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable \"definition specifier\" for METHOD." + (let* ((gf (clos:method-generic-function method)) + (name (clos:generic-function-name gf)) + (specializers (clos:method-specializers method)) + (qualifiers (clos:method-qualifiers method))) + `(method ,name ,@qualifiers ,specializers #+nil (clos::unparse-specializers specializers)))) + +;; XXX maybe special case setters/getters +(defun method-location (method) + (function-location (clos:method-function method))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (find-class name nil))) + (etypecase class + (null '()) + (structure-class + (list (list `(defstruct ,name) + (dd-location (find-dd name))))) + (standard-class + (list (list `(defclass ,name) + (class-location (find-class name))))) + ((or built-in-class + kernel:funcallable-structure-class) + (list (list `(kernel::define-type-class ,name) + `(:error + ,(format nil "No source info for ~A" name))))))))) + +(defun class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (class-name class))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((name (class-name class))) + `(:error ,(format nil "No location info for condition: ~A" name)))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun definition-source-location (object name) + `(:error ,(format nil "No source info for: ~A" object))) + +(defun setf-definitions (name) + (let ((function (or (ext:info :setf :inverse name) + (ext:info :setf :expander name)))) + (if function + (list (list `(setf ,name) + (function-location (coerce function 'function))))))) + + +(defun variable-location (symbol) + `(:error ,(format nil "No source info for variable ~S" symbol))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(c::vop ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unknown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (etypecase fun + (function (function-arglist fun)) + (symbol (function-arglist (or (macro-function fun) + (symbol-function fun)))))) + +(defun function-arglist (fun) + (flet ((compiled-function-arglist (x) + (let ((args (kernel:%function-arglist x))) + (if args + (read-arglist x) + :not-available)))) + (case (kernel:get-type fun) + (#.vm:closure-header-type + (compiled-function-arglist + (kernel:%closure-function fun))) + ((#.vm:function-header-type #.vm:closure-function-header-type) + (compiled-function-arglist fun)) + (#.vm:funcallable-instance-header-type + (typecase fun + (kernel:byte-function + :not-available) + (kernel:byte-closure + :not-available) + (eval:interpreted-function + (eval:interpreted-function-arglist fun)) + (otherwise + (clos::generic-function-lambda-list fun)))) + (t + :non-available)))) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((typep function 'generic-function) + (clos:generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + +;;; A simple case: the arglist is available as a string that we can +;;; `read'. + +(defun read-arglist (fn) + "Parse the arglist-string of the function object FN." + (let ((string (kernel:%function-arglist + (kernel:%function-self fn))) + (package (find-package + (c::compiled-debug-info-package + (kernel:%code-debug-info + (vm::find-code-object fn)))))) + (with-standard-io-syntax + (let ((*package* (or package *package*))) + (read-from-string string))))) + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. + A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + +;;; Deriving arglists for byte-compiled functions: +;;; +(defun byte-code-function-arglist (fn) + ;; There doesn't seem to be much arglist information around for + ;; byte-code functions. Use the arg-count and return something like + ;; (arg0 arg1 ...) + (etypecase fn + (c::simple-byte-function + (loop for i from 0 below (c::simple-byte-function-num-args fn) + collect (make-arg-symbol i))) + (c::hairy-byte-function + (hairy-byte-function-arglist fn)) + (c::byte-closure + (byte-code-function-arglist (c::byte-closure-function fn))))) + +(defun make-arg-symbol (i) + (make-symbol (format nil "~A~D" (string 'arg) i))) + +;;; A "hairy" byte-function is one that takes a variable number of +;;; arguments. `hairy-byte-function' is a type from the bytecode +;;; interpreter. +;;; +(defun hairy-byte-function-arglist (fn) + (let ((counter -1)) + (flet ((next-arg () (make-arg-symbol (incf counter)))) + (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p + keywords-p keywords) fn + (let ((arglist '()) + (optional (- max-args min-args))) + ;; XXX isn't there a better way to write this? + ;; (Looks fine to me. -luke) + (dotimes (i min-args) + (push (next-arg) arglist)) + (when (plusp optional) + (push '&optional arglist) + (dotimes (i optional) + (push (next-arg) arglist))) + (when rest-arg-p + (push '&rest arglist) + (push (next-arg) arglist)) + (when keywords-p + (push '&key arglist) + (loop for (key _ __) in keywords + do (push key arglist)) + (when (eq keywords-p :allow-others) + (push '&allow-other-keys arglist))) + (nreverse arglist)))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form) + (macroexpand form)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation call-without-interrupts (fn) + (funcall fn)) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + (if (eq ext:*case-mode* :upper) "scl" "scl-lower")) + +(defimplementation quit-lisp () + (ext:quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; swank-source-path-parser + + +;;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error (make-condition + 'sldb-condition + :original-condition condition))))) + (funcall debugger-loop-fn)))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (frame-down f) + for i from start below end + while f + collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location-for-emacs (index) + (code-location-source-location (di:frame-code-location (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (di::debug-function-debug-variables (di:frame-debug-function frame))) + +(defun debug-var-value (var frame location) + (let ((validity (di:debug-variable-validity var location))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (di:frame-code-location frame)) + (vars (frame-debug-vars frame))) + (loop for v across vars collect + (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame loc))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame (di:frame-code-location frame)))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of SCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sldb-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:ucontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:ucontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; SCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<<known-return convention not supported>>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol (symbol-name '#:function-end-breakpoint-values/standard) + :debug-internals))) + (cond (sym (funcall sym sigcontext)) + (t (di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +#+nil +(defimplementation condition-extras ((c breakpoint)) + ;; simply pop up the source buffer + `((:short-frame-source 0))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +#+nil +(defimplementation sldb-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + ((or di::bogus-debug-function di::interpreted-debug-function) + -1))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +CSP = ~X +CFP = ~X +IP = ~X +OCFP = ~X +LRA = ~X~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + + +(defimplementation disassemble-frame (frame-number) + "Return a string with the disassembly of frames code." + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (format t "~%[Disassembling bogus frames not implemented]"))))) + + +;;;; Inspecting + +(defclass scl-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'scl-inspector)) + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:instance-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:function-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp (symbol-name '#:-type) (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list (symbol-name '#:-type) :vm) + (apropos-list (symbol-name '#:-type) :bignum)))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (cond ((di::indirect-value-cell-p o) + (values (format nil "~A is a value cell." o) + `("Value: " (:value ,(c:value-cell-ref o))))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (scl-inspect o)))) + +(defun scl-inspect (o) + (destructuring-bind (text labeledp . parts) + (inspect::describe-parts o) + (values (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) + (declare (ignore inspector)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (values (format nil "~A is a function." o) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s)))))) + ((= header vm:closure-header-type) + (values (format nil "~A is a closure" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (- (kernel:get-closure-length o) + (1- vm:closure-info-offset)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (scl-inspect o)) + (t + (call-next-method))))) + + +(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector)) + (declare (ignore _)) + (values (format nil "~A is a code data-block." o) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" (:newline) + , (with-output-to-string (s) + (cond ((kernel:%code-debug-info o) + (disassem:disassemble-code-component o :stream s)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift) + :stream s)))))))) + +(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector)) + (declare (ignore inspector)) + (values (format nil "~A is a fdenf object." o) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) + +(defmethod inspect-for-emacs ((o array) (inspector backend-inspector)) + inspector + (cond ((kernel:array-header-p o) + (values (format nil "~A is an array." o) + (label-value-line* + (:header (describe-primitive-type o)) + (:rank (array-rank o)) + (:fill-pointer (kernel:%array-fill-pointer o)) + (:fill-pointer-p (kernel:%array-fill-pointer-p o)) + (:elements (kernel:%array-available-elements o)) + (:data (kernel:%array-data-vector o)) + (:displacement (kernel:%array-displacement o)) + (:displaced-p (kernel:%array-displaced-p o)) + (:dimensions (array-dimensions o))))) + (t + (values (format nil "~A is an simple-array." o) + (label-value-line* + (:header (describe-primitive-type o)) + (:length (length o))))))) + +(defmethod inspect-for-emacs ((o simple-vector) (inspector backend-inspector)) + inspector + (values (format nil "~A is a vector." o) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (unless (eq (array-element-type o) 'nil) + (loop for i below (length o) + append (label-value-line i (aref o i))))))) + +(defun inspect-alien-record (alien) + (values + (format nil "~A is an alien value." alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (label-value-line slot (alien:slot alien slot))))))))) + +(defun inspect-alien-pointer (alien) + (values + (format nil "~A is an alien value." alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien)))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (scl-inspect alien)))) + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + #+nil :methods #+nil methods)) + + +;;;; Multiprocessing + +(defimplementation spawn (fn &key name) + (thread:thread-create fn :name (or name "Anonymous"))) + +(defvar *thread-id-counter* 0) +(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter")) + +(defimplementation thread-id (thread) + (thread:with-lock-held (*thread-id-counter-lock*) + (or (getf (thread:thread-plist thread) 'id) + (setf (getf (thread:thread-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (block find-thread + (thread:map-over-threads + #'(lambda (thread) + (when (eql (getf (thread:thread-plist thread) 'id) id) + (return-from find-thread thread)))))) + +(defimplementation thread-name (thread) + (princ-to-string (thread:thread-name thread))) + +(defimplementation thread-status (thread) + (let ((dynamic-values (thread::thread-dynamic-values thread))) + (if (zerop dynamic-values) "Exited" "Running"))) + +(defimplementation make-lock (&key name) + (thread:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (thread:with-lock-held (lock) (funcall function))) + +(defimplementation current-thread () + thread:*thread*) + +(defimplementation all-threads () + (let ((all-threads nil)) + (thread:map-over-threads #'(lambda (thread) (push thread all-threads))) + all-threads)) + +(defimplementation interrupt-thread (thread fn) + (thread:thread-interrupt thread #'(lambda () + (sys:with-interrupts + (funcall fn))))) + +(defimplementation kill-thread (thread) + (thread:destroy-thread thread)) + +(defimplementation thread-alive-p (thread) + (not (zerop (thread::thread-dynamic-values thread)))) + +(defvar *mailbox-lock* (thread:make-lock "Mailbox lock")) + +(defstruct (mailbox) + (lock (thread:make-lock "Thread mailbox" :type :error-check + :interruptible nil) + :type thread:error-check-lock) + (queue '() :type list)) + +(defun mailbox (thread) + "Return 'thread's mailbox." + (thread:with-lock-held (*mailbox-lock*) + (or (getf (thread:thread-plist thread) 'mailbox) + (setf (getf (thread:thread-plist thread) 'mailbox) (make-mailbox))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (lock (mailbox-lock mbox))) + (sys:without-interrupts + (thread:with-lock-held (lock "Mailbox Send") + (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) + (list message))))) + (mp:process-wakeup thread) + message)) + +(defimplementation receive () + (let* ((mbox (mailbox thread:*thread*)) + (lock (mailbox-lock mbox))) + (loop + (mp:process-wait-with-timeout "Mailbox read wait" 1 + #'(lambda () (mailbox-queue mbox))) + (multiple-value-bind (message winp) + (sys:without-interrupts + (mp:with-lock-held (lock "Mailbox read") + (let ((queue (mailbox-queue mbox))) + (cond (queue + (setf (mailbox-queue mbox) (cdr queue)) + (values (car queue) t)) + (t + (values nil nil)))))) + (when winp + (return message)))))) + + + +(defimplementation emacs-connected ()) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;; In SCL, we have: +;; (trace <name>) +;; (trace (method <name> <qualifier>? (<specializer>+))) +;; (trace :methods t '<name>) ;;to trace all methods of the gf <name> +;; <name> can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + nil) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ;; this isn't actually supported + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +;;; Weak datastructures + +;;; Not implemented in SCL. +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) + +;; Local Variables: +;; pbook-heading-regexp: "^;;;\$;+\$" +;; pbook-commentary-regexp: "^;;;\$$\\|[^;]\$" +;; End: Added: branches/trunk-reorg/thirdparty/slime/swank-source-file-cache.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-source-file-cache.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-source-file-cache.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,118 @@ +;;;; Source-file cache +;;; +;;; To robustly find source locations in CMUCL and SBCL it's useful to +;;; have the exact source code that the loaded code was compiled from. +;;; In this source we can accurately find the right location, and from +;;; that location we can extract a "snippet" of code to show what the +;;; definition looks like. Emacs can use this snippet in a best-match +;;; search to locate the right definition, which works well even if +;;; the buffer has been modified. +;;; +;;; The idea is that if a definition previously started with +;;; `(define-foo bar' then it probably still does. +;;; +;;; Whenever we see that the file on disk has the same +;;; `file-write-date' as a location we're looking for we cache the +;;; whole file inside Lisp. That way we will still have the matching +;;; version even if the file is later modified on disk. If the file is +;;; later recompiled and reloaded then we replace our cache entry. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(in-package :swank-backend) + +(defvar *cache-sourcecode* t + "When true complete source files are cached. +The cache is used to keep known good copies of the source text which +correspond to the loaded code. Finding definitions is much more +reliable when the exact source is available, so we cache it in case it +gets edited on disk later.") + +(defvar *source-file-cache* (make-hash-table :test 'equal) + "Cache of source file contents. +Maps from truename to source-cache-entry structure.") + +(defstruct (source-cache-entry + (:conc-name source-cache-entry.) + (:constructor make-source-cache-entry (text date))) + text date) + +(defimplementation buffer-first-change (filename) + "Load a file into the cache when the user modifies its buffer. +This is a win if the user then saves the file and tries to M-. into it." + (unless (source-cached-p filename) + (ignore-errors + (source-cache-get filename (file-write-date filename)))) + nil) + +(defun get-source-code (filename code-date) + "Return the source code for FILENAME as written on DATE in a string. +If the exact version cannot be found then return the current one from disk." + (or (source-cache-get filename code-date) + (read-file filename))) + +(defun source-cache-get (filename date) + "Return the source code for FILENAME as written on DATE in a string. +Return NIL if the right version cannot be found." + (when *cache-sourcecode* + (let ((entry (gethash filename *source-file-cache*))) + (cond ((and entry (equal date (source-cache-entry.date entry))) + ;; Cache hit. + (source-cache-entry.text entry)) + ((or (null entry) + (not (equal date (source-cache-entry.date entry)))) + ;; Cache miss. + (if (equal (file-write-date filename) date) + ;; File on disk has the correct version. + (let ((source (read-file filename))) + (setf (gethash filename *source-file-cache*) + (make-source-cache-entry source date)) + source) + nil)))))) + +(defun source-cached-p (filename) + "Is any version of FILENAME in the source cache?" + (if (gethash filename *source-file-cache*) t)) + +(defun read-file (filename) + "Return the entire contents of FILENAME as a string." + (with-open-file (s filename :direction :input + :external-format (or (guess-external-format filename) + (find-external-format "latin-1") + :default)) + (let ((string (make-string (file-length s)))) + (read-sequence string s) + string))) + +;;;; Snippets + +(defvar *source-snippet-size* 256 + "Maximum number of characters in a snippet of source code. +Snippets at the beginning of definitions are used to tell Emacs what +the definitions looks like, so that it can accurately find them by +text search.") + +(defun read-snippet (stream &optional position) + "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM. +If POSITION is given, set the STREAM's file position first." + (when position + (file-position stream position)) + #+SBCL (skip-comments-and-whitespace stream) + (read-upto-n-chars stream *source-snippet-size*)) + +(defun skip-comments-and-whitespace (stream) + (case (peek-char nil stream) + ((#\Space #\Tab #\Newline #\Linefeed) + (read-char stream) + (skip-comments-and-whitespace stream)) + (#\; + (read-line stream) + (skip-comments-and-whitespace stream)))) + +(defun read-upto-n-chars (stream n) + "Return a string of upto N chars from STREAM." + (let* ((string (make-string n)) + (chars (read-sequence string stream))) + (subseq string 0 chars))) + Added: branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,131 @@ +;;;; Source-paths + +;;; CMUCL/SBCL use a data structure called "source-path" to locate +;;; subforms. The compiler assigns a source-path to each form in a +;;; compilation unit. Compiler notes usually contain the source-path +;;; of the error location. +;;; +;;; Compiled code objects don't contain source paths, only the +;;; "toplevel-form-number" and the (sub-) "form-number". To get from +;;; the form-number to the source-path we need the entire toplevel-form +;;; (i.e. we have to read the source code). CMUCL has already some +;;; utilities to do this translation, but we use some extended +;;; versions, because we need more exact position info. Apparently +;;; Hemlock is happy with the position of the toplevel-form; we also +;;; need the position of subforms. +;;; +;;; We use a special readtable to get the positions of the subforms. +;;; The readtable stores the start and end position for each subform in +;;; hashtable for later retrieval. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +;;; Taken from swank-cmucl.lisp, by Helmut Eller + +(in-package :swank-backend) + +;; Some test to ensure the required conformance +(let ((rt (copy-readtable nil))) + (assert (or (not (get-macro-character #\space rt)) + (nth-value 1 (get-macro-character #\space rt)))) + (assert (not (get-macro-character #\\ rt)))) + +(defun make-source-recorder (fn source-map) + "Return a macro character function that does the same as FN, but +additionally stores the result together with the stream positions +before and after of calling FN in the hashtable SOURCE-MAP." + (declare (type function fn)) + (lambda (stream char) + (let ((start (file-position stream)) + (values (multiple-value-list (funcall fn stream char))) + (end (file-position stream))) + ;;(format t "[~D ~{~A~^, ~} ~D ~D]~%" start values end (char-code char)) + (unless (null values) + (push (cons start end) (gethash (car values) source-map))) + (values-list values)))) + +(defun make-source-recording-readtable (readtable source-map) + "Return a source position recording copy of READTABLE. +The source locations are stored in SOURCE-MAP." + (let* ((tab (copy-readtable readtable)) + (*readtable* tab)) + (dotimes (code 128) + (let ((char (code-char code))) + (multiple-value-bind (fn term) (get-macro-character char tab) + (when fn + (set-macro-character char (make-source-recorder fn source-map) + term tab))))) + (suppress-sharp-dot tab) + tab)) + +(defun suppress-sharp-dot (readtable) + (when (get-macro-character #\# readtable) + (let ((sharp-dot (get-dispatch-macro-character #\# #\. readtable))) + (set-dispatch-macro-character #\# #\. (lambda (&rest args) + (let ((*read-suppress* t)) + (apply sharp-dot args)) + (if *read-suppress* + (values) + (list (gensym "#.")))) + readtable)))) + +(defun read-and-record-source-map (stream) + "Read the next object from STREAM. +Return the object together with a hashtable that maps +subexpressions of the object to stream positions." + (let* ((source-map (make-hash-table :test #'eq)) + (*readtable* (make-source-recording-readtable *readtable* source-map)) + (start (file-position stream)) + (form (read stream)) + (end (file-position stream))) + ;; ensure that at least FORM is in the source-map + (unless (gethash form source-map) + (push (cons start end) (gethash form source-map))) + (values form source-map))) + +(defun read-source-form (n stream) + "Read the Nth toplevel form number with source location recording. +Return the form and the source-map." + (let ((*read-suppress* t)) + (dotimes (i n) + (read stream))) + (let ((*read-suppress* nil) + (*read-eval* nil)) + (read-and-record-source-map stream))) + +(defun source-path-stream-position (path stream) + "Search the source-path PATH in STREAM and return its position." + (check-source-path path) + (destructuring-bind (tlf-number . path) path + (multiple-value-bind (form source-map) (read-source-form tlf-number stream) + (source-path-source-position (cons 0 path) form source-map)))) + +(defun check-source-path (path) + (unless (and (consp path) + (every #'integerp path)) + (error "The source-path ~S is not valid." path))) + +(defun source-path-string-position (path string) + (with-input-from-string (s string) + (source-path-stream-position path s))) + +(defun source-path-file-position (path filename) + (with-open-file (file filename) + (source-path-stream-position path file))) + +(defun source-path-source-position (path form source-map) + "Return the start position of PATH from FORM and SOURCE-MAP. All +subforms along the path are considered and the start and end position +of the deepest (i.e. smallest) possible form is returned." + ;; compute all subforms along path + (let ((forms (loop for n in path + for f = form then (nth n f) + collect f))) + ;; select the first subform present in source-map + (loop for form in (reverse forms) + for positions = (gethash form source-map) + until (and positions (null (cdr positions))) + finally (destructuring-bind ((start . end)) positions + (return (values (1- start) end)))))) + Added: branches/trunk-reorg/thirdparty/slime/swank.asd =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank.asd 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank.asd 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,48 @@ +;;; -*- lisp -*- + +;; ASDF system definition for loading the Swank server independently +;; of Emacs. +;; +;; This is only useful if you want to start a Swank server in a Lisp +;; processes that doesn't run under Emacs. Lisp processes created by +;; `M-x slime' automatically start the server. + +;; Usage: +;; +;; (require :swank) +;; (swank:create-swank-server PORT) => ACTUAL-PORT +;; +;; (PORT can be zero to mean "any available port".) +;; Then the Swank server is running on localhost:ACTUAL-PORT. You can +;; use `M-x slime-connect' to connect Emacs to it. +;; +;; This code has been placed in the Public Domain. All warranties +;; are disclaimed. + +(defpackage :swank-loader + (:use :cl)) + +(in-package :swank-loader) + +(defclass cl-script-file (asdf:source-file) ()) + +(defmethod asdf:perform ((o asdf:compile-op) (f cl-script-file)) + t) +(defmethod asdf:perform ((o asdf:load-op) (f cl-script-file)) + (mapcar #'load (asdf:input-files o f))) +(defmethod asdf:output-files ((o asdf:compile-op) (f cl-script-file)) + nil) +(defmethod asdf:input-files ((o asdf:load-op) (c cl-script-file)) + (list (asdf:component-pathname c))) +(defmethod asdf:operation-done-p ((o asdf:compile-op) (c cl-script-file)) + t) +(defmethod asdf:source-file-type ((c cl-script-file) (s asdf:module)) + "lisp") + +(asdf:defsystem :swank + :default-component-class cl-script-file + :components ((:file "swank-loader"))) + +(defparameter *source-directory* + (asdf:component-pathname (asdf:find-system :swank))) + Added: branches/trunk-reorg/thirdparty/slime/swank.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,3198 @@ +;;; -*- outline-regexp:";;;;;*" indent-tabs-mode:nil coding:latin-1-unix -*- +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; +;;;; swank.lisp +;;; +;;; This file defines the "Swank" TCP server for Emacs to talk to. The +;;; code in this file is purely portable Common Lisp. We do require a +;;; smattering of non-portable functions in order to write the server, +;;; so we have defined them in `swank-backend.lisp' and implemented +;;; them separately for each Lisp implementation. These extensions are +;;; available to us here via the `SWANK-BACKEND' package. + +(defpackage :swank + (:use :common-lisp :swank-backend) + (:export #:startup-multiprocessing + #:start-server + #:create-server + #:ed-in-emacs + #:inspect-in-emacs + #:print-indentation-lossage + #:swank-debugger-hook + #:run-after-init-hook + #:inspect-for-emacs + #:inspect-slot-for-emacs + ;; These are user-configurable variables: + #:*communication-style* + #:*dont-close* + #:*log-events* + #:*log-output* + #:*use-dedicated-output-stream* + #:*dedicated-output-stream-port* + #:*configure-emacs-indentation* + #:*readtable-alist* + #:*globally-redirect-io* + #:*global-debugger* + #:*sldb-printer-bindings* + #:*swank-pprint-bindings* + #:*default-worker-thread-bindings* + #:*macroexpand-printer-bindings* + #:*record-repl-results* + #:*debug-on-swank-error* + ;; These are re-exported directly from the backend: + #:buffer-first-change + #:frame-source-location-for-emacs + #:restart-frame + #:sldb-step + #:sldb-break + #:sldb-break-on-return + #:profiled-functions + #:profile-report + #:profile-reset + #:unprofile-all + #:profile-package + #:default-directory + #:set-default-directory + #:quit-lisp)) + +(in-package :swank) + + +;;;; Top-level variables, constants, macros + +(defconstant cl-package (find-package :cl) + "The COMMON-LISP package.") + +(defconstant keyword-package (find-package :keyword) + "The KEYWORD package.") + +(defvar *canonical-package-nicknames* + `((:common-lisp-user . :cl-user)) + "Canonical package names to use instead of shortest name/nickname.") + +(defvar *auto-abbreviate-dotted-packages* t + "Abbreviate dotted package names to their last component if T.") + +(defvar *swank-io-package* + (let ((package (make-package :swank-io-package :use '()))) + (import '(nil t quote) package) + package)) + +(defconstant default-server-port 4005 + "The default TCP port for the server (when started manually).") + +(defvar *swank-debug-p* t + "When true, print extra debugging information.") + +(defvar *redirect-io* t + "When non-nil redirect Lisp standard I/O to Emacs. +Redirection is done while Lisp is processing a request for Emacs.") + +(defvar *sldb-printer-bindings* + `((*print-pretty* . t) + (*print-level* . 4) + (*print-length* . 10) + (*print-circle* . t) + (*print-readably* . nil) + (*print-pprint-dispatch* . ,(copy-pprint-dispatch nil)) + (*print-gensym* . t) + (*print-base* . 10) + (*print-radix* . nil) + (*print-array* . t) + (*print-lines* . 10) + (*print-escape* . t) + (*print-right-margin* . 70)) + "A set of printer variables used in the debugger.") + +(defvar *default-worker-thread-bindings* '() + "An alist to initialize dynamic variables in worker threads. +The list has the form ((VAR . VALUE) ...). Each variable VAR will be +bound to the corresponding VALUE.") + +(defun call-with-bindings (alist fun) + "Call FUN with variables bound according to ALIST. +ALIST is a list of the form ((VAR . VAL) ...)." + (let* ((rlist (reverse alist)) + (vars (mapcar #'car rlist)) + (vals (mapcar #'cdr rlist))) + (progv vars vals + (funcall fun)))) + +(defmacro with-bindings (alist &body body) + "See `call-with-bindings'." + `(call-with-bindings ,alist (lambda () ,@body))) + +;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via +;;; RPC. + +(defmacro defslimefun (name arglist &body rest) + "A DEFUN for functions that Emacs can call by RPC." + `(progn + (defun ,name ,arglist ,@rest) + ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler…> + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name :swank)))) + +(defun missing-arg () + "A function that the compiler knows will never to return a value. +You can use (MISSING-ARG) as the initform for defstruct slots that +must always be supplied. This way the :TYPE slot option need not +include some arbitrary initial value like NIL." + (error "A required &KEY or &OPTIONAL argument was not supplied.")) + + +;;;; Hooks +;;; +;;; We use Emacs-like `add-hook' and `run-hook' utilities to support +;;; simple indirection. The interface is more CLish than the Emacs +;;; Lisp one. + +(defmacro add-hook (place function) + "Add FUNCTION to the list of values on PLACE." + `(pushnew ,function ,place)) + +(defun run-hook (functions &rest arguments) + "Call each of FUNCTIONS with ARGUMENTS." + (dolist (function functions) + (apply function arguments))) + +(defvar *new-connection-hook* '() + "This hook is run each time a connection is established. +The connection structure is given as the argument. +Backend code should treat the connection structure as opaque.") + +(defvar *connection-closed-hook* '() + "This hook is run when a connection is closed. +The connection as passed as an argument. +Backend code should treat the connection structure as opaque.") + +(defvar *pre-reply-hook* '() + "Hook run (without arguments) immediately before replying to an RPC.") + +(defvar *after-init-hook* '() + "Hook run after user init files are loaded.") + +(defun run-after-init-hook () + (run-hook *after-init-hook*)) + + +;;;; Connections +;;; +;;; Connection structures represent the network connections between +;;; Emacs and Lisp. Each has a socket stream, a set of user I/O +;;; streams that redirect to Emacs, and optionally a second socket +;;; used solely to pipe user-output to Emacs (an optimization). +;;; + +(defstruct (connection + (:conc-name connection.) + (:print-function print-connection)) + ;; Raw I/O stream of socket connection. + (socket-io (missing-arg) :type stream :read-only t) + ;; Optional dedicated output socket (backending `user-output' slot). + ;; Has a slot so that it can be closed with the connection. + (dedicated-output nil :type (or stream null)) + ;; Streams that can be used for user interaction, with requests + ;; redirected to Emacs. + (user-input nil :type (or stream null)) + (user-output nil :type (or stream null)) + (user-io nil :type (or stream null)) + ;; A stream that we use for *trace-output*; if nil, we user user-output. + (trace-output nil :type (or stream null)) + ;; A stream where we send REPL results. + (repl-results nil :type (or stream null)) + ;; In multithreaded systems we delegate certain tasks to specific + ;; threads. The `reader-thread' is responsible for reading network + ;; requests from Emacs and sending them to the `control-thread'; the + ;; `control-thread' is responsible for dispatching requests to the + ;; threads that should handle them; the `repl-thread' is the one + ;; that evaluates REPL expressions. The control thread dispatches + ;; all REPL evaluations to the REPL thread and for other requests it + ;; spawns new threads. + reader-thread + control-thread + repl-thread + ;; Callback functions: + ;; (SERVE-REQUESTS <this-connection>) serves all pending requests + ;; from Emacs. + (serve-requests (missing-arg) :type function) + ;; (READ) is called to read and return one message from Emacs. + (read (missing-arg) :type function) + ;; (SEND OBJECT) is called to send one message to Emacs. + (send (missing-arg) :type function) + ;; (CLEANUP <this-connection>) is called when the connection is + ;; closed. + (cleanup nil :type (or null function)) + ;; Cache of macro-indentation information that has been sent to Emacs. + ;; This is used for preparing deltas to update Emacs's knowledge. + ;; Maps: symbol -> indentation-specification + (indentation-cache (make-hash-table :test 'eq) :type hash-table) + ;; The list of packages represented in the cache: + (indentation-cache-packages '()) + ;; The communication style used. + (communication-style nil :type (member nil :spawn :sigio :fd-handler)) + ;; The coding system for network streams. + (coding-system )) + +(defun print-connection (conn stream depth) + (declare (ignore depth)) + (print-unreadable-object (conn stream :type t :identity t))) + +(defvar *connections* '() + "List of all active connections, with the most recent at the front.") + +(defvar *emacs-connection* nil + "The connection to Emacs currently in use.") + +(defvar *swank-state-stack* '() + "A list of symbols describing the current state. Used for debugging +and to detect situations where interrupts can be ignored.") + +(defun default-connection () + "Return the 'default' Emacs connection. +This connection can be used to talk with Emacs when no specific +connection is in use, i.e. *EMACS-CONNECTION* is NIL. + +The default connection is defined (quite arbitrarily) as the most +recently established one." + (first *connections*)) + +(defslimefun state-stack () + "Return the value of *SWANK-STATE-STACK*." + *swank-state-stack*) + +;; A conditions to include backtrace information +(define-condition swank-error (error) + ((condition :initarg :condition :reader swank-error.condition) + (backtrace :initarg :backtrace :reader swank-error.backtrace)) + (:report (lambda (condition stream) + (princ (swank-error.condition condition) stream)))) + +(defun make-swank-error (condition) + (let ((bt (ignore-errors + (call-with-debugging-environment + (lambda () (backtrace 0 nil)))))) + (make-condition 'swank-error :condition condition :backtrace bt))) + +(add-hook *new-connection-hook* 'notify-backend-of-connection) +(defun notify-backend-of-connection (connection) + (declare (ignore connection)) + (emacs-connected)) + + +;;;; Utilities + +;;;;; Helper macros + +(defmacro with-io-redirection ((connection) &body body) + "Execute BODY I/O redirection to CONNECTION. +If *REDIRECT-IO* is true then all standard I/O streams are redirected." + `(maybe-call-with-io-redirection ,connection (lambda () ,@body))) + +(defun maybe-call-with-io-redirection (connection fun) + (if *redirect-io* + (call-with-redirected-io connection fun) + (funcall fun))) + +(defmacro with-connection ((connection) &body body) + "Execute BODY in the context of CONNECTION." + `(call-with-connection ,connection (lambda () ,@body))) + +(defun call-with-connection (connection fun) + (let ((*emacs-connection* connection)) + (with-io-redirection (*emacs-connection*) + (call-with-debugger-hook #'swank-debugger-hook fun)))) + +(defmacro without-interrupts (&body body) + `(call-without-interrupts (lambda () ,@body))) + +(defmacro destructure-case (value &rest patterns) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (gensym "op-")) + (operands (gensym "rand-")) + (tmp (gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (case ,operator + ,@(loop for (pattern . body) in patterns collect + (if (eq pattern t) + `(t ,@body) + (destructuring-bind (op &rest rands) pattern + `(,op (destructuring-bind ,rands ,operands + ,@body))))) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "destructure-case failed: ~S" ,tmp)))))))) + +(defmacro with-temp-package (var &body body) + "Execute BODY with VAR bound to a temporary package. +The package is deleted before returning." + `(let ((,var (make-package (gensym "TEMP-PACKAGE-")))) + (unwind-protect (progn ,@body) + (delete-package ,var)))) + +(defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body) + "Just like do-symbols, but makes sure a symbol is visited only once." + (let ((seen-ht (gensym "SEEN-HT"))) + `(let ((,seen-ht (make-hash-table :test #'eq))) + (do-symbols (,var ,package ,result-form) + (unless (gethash ,var ,seen-ht) + (setf (gethash ,var ,seen-ht) t) + ,@body))))) + + +;;;;; Logging + +(defvar *log-events* nil) +(defvar *log-output* *error-output*) +(defvar *event-history* (make-array 40 :initial-element nil) + "A ring buffer to record events for better error messages.") +(defvar *event-history-index* 0) +(defvar *enable-event-history* t) + +(defun log-event (format-string &rest args) + "Write a message to *terminal-io* when *log-events* is non-nil. +Useful for low level debugging." + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-pretty* nil) + (*package* *swank-io-package*)) + (when *enable-event-history* + (setf (aref *event-history* *event-history-index*) + (format nil "~?" format-string args)) + (setf *event-history-index* + (mod (1+ *event-history-index*) (length *event-history*)))) + (when *log-events* + (apply #'format *log-output* format-string args) + (force-output *log-output*))))) + +(defun event-history-to-list () + "Return the list of events (older events first)." + (let ((arr *event-history*) + (idx *event-history-index*)) + (concatenate 'list (subseq arr idx) (subseq arr 0 idx)))) + +(defun dump-event-history (stream) + (dolist (e (event-history-to-list)) + (dump-event e stream))) + +(defun dump-event (event stream) + (cond ((stringp event) + (write-string (escape-non-ascii event) stream)) + ((null event)) + (t (format stream "Unexpected event: ~A~%" event)))) + +(defun escape-non-ascii (string) + "Return a string like STRING but with non-ascii chars escaped." + (cond ((ascii-string-p string) string) + (t (with-output-to-string (out) + (loop for c across string do + (cond ((ascii-char-p c) (write-char c out)) + (t (format out "\\x~4,'0X" (char-code c))))))))) + +(defun ascii-string-p (o) + (and (stringp o) + (every #'ascii-char-p o))) + +(defun ascii-char-p (c) + (<= (char-code c) 127)) + + +;;;;; Misc + +(defun length= (seq n) + "Test for whether SEQ contains N number of elements. I.e. it's equivalent + to (= (LENGTH SEQ) N), but besides being more concise, it may also be more + efficiently implemented." + (etypecase seq + (list (do ((i n (1- i)) + (list seq (cdr list))) + ((or (<= i 0) (null list)) + (and (zerop i) (null list))))) + (sequence (= (length seq) n)))) + +(defun ensure-list (thing) + (if (listp thing) thing (list thing))) + +(defun recursively-empty-p (list) + "Returns whether LIST consists only of arbitrarily nested empty lists." + (cond ((not (listp list)) nil) + ((null list) t) + (t (every #'recursively-empty-p list)))) + +(defun maybecall (bool fn &rest args) + "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values." + (if bool (apply fn args) (values-list args))) + +(defun exactly-one-p (&rest values) + "If exactly one value in VALUES is non-NIL, this value is returned. +Otherwise NIL is returned." + (let ((found nil)) + (dolist (v values) + (when v (if found + (return-from exactly-one-p nil) + (setq found v)))) + found)) + + +;;;;; Symbols + +(defun symbol-status (symbol &optional (package (symbol-package symbol))) + "Returns one of + + :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol, + + :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol, + + :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE, + but is not _present_ in PACKAGE, + + or NIL if SYMBOL is not _accessible_ in PACKAGE. + + +Be aware not to get confused with :INTERNAL and how \"internal +symbols\" are defined in the spec; there is a slight mismatch of +definition with the Spec and what's commonly meant when talking +about internal symbols most times. As the spec says: + + In a package P, a symbol S is + + _accessible_ if S is either _present_ in P itself or was + inherited from another package Q (which implies + that S is _external_ in Q.) + + You can check that with: (AND (SYMBOL-STATUS S P) T) + + + _present_ if either P is the /home package/ of S or S has been + imported into P or exported from P by IMPORT, or + EXPORT respectively. + + Or more simply, if S is not _inherited_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :INHERITED)))) + + + _external_ if S is going to be inherited into any package that + /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or + DEFPACKAGE. + + Note that _external_ implies _present_, since to + make a symbol _external_, you'd have to use EXPORT + which will automatically make the symbol _present_. + + You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL) + + + _internal_ if S is _accessible_ but not _external_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :EXTERNAL)))) + + + Notice that this is *different* to + (EQ (SYMBOL-STATUS S P) :INTERNAL) + because what the spec considers _internal_ is split up into two + explicit pieces: :INTERNAL, and :INHERITED; just as, for instance, + CL:FIND-SYMBOL does. + + The rationale is that most times when you speak about \"internal\" + symbols, you're actually not including the symbols inherited + from other packages, but only about the symbols directly specific + to the package in question. +" + (when package ; may be NIL when symbol is completely uninterned. + (check-type symbol symbol) (check-type package package) + (multiple-value-bind (present-symbol status) + (find-symbol (symbol-name symbol) package) + (and (eq symbol present-symbol) status)))) + +(defun symbol-external-p (symbol &optional (package (symbol-package symbol))) + "True if SYMBOL is external in PACKAGE. +If PACKAGE is not specified, the home package of SYMBOL is used." + (eq (symbol-status symbol package) :external)) + + +(defun classify-symbol (symbol) + "Returns a list of classifiers that classify SYMBOL according +to its underneath objects (e.g. :BOUNDP if SYMBOL constitutes a +special variable.) The list may contain the following classification +keywords: :BOUNDP, :FBOUNDP, :GENERIC-FUNCTION, :CLASS, :MACRO, +:SPECIAL-OPERATOR, and/or :PACKAGE" + (check-type symbol symbol) + (let (result) + (when (boundp symbol) (push :boundp result)) + (when (fboundp symbol) (push :fboundp result)) + (when (find-class symbol nil) (push :class result)) + (when (macro-function symbol) (push :macro result)) + (when (special-operator-p symbol) (push :special-operator result)) + (when (find-package symbol) (push :package result)) + (when (typep (ignore-errors (fdefinition symbol)) + 'generic-function) + (push :generic-function result)) + result)) + +(defun symbol-classification->string (flags) + (format nil "~A~A~A~A~A~A~A" + (if (member :boundp flags) "b" "-") + (if (member :fboundp flags) "f" "-") + (if (member :generic-function flags) "g" "-") + (if (member :class flags) "c" "-") + (if (member :macro flags) "m" "-") + (if (member :special-operator flags) "s" "-") + (if (member :package flags) "p" "-"))) + + +;;;; TCP Server + +(defvar *use-dedicated-output-stream* nil + "When T swank will attempt to create a second connection to + Emacs which is used just to send output.") + +(defvar *dedicated-output-stream-port* 0 + "Which port we should use for the dedicated output stream.") + +(defvar *communication-style* (preferred-communication-style)) + +(defvar *dont-close* nil + "Default value of :dont-close argument to start-server and + create-server.") + +(defvar *dedicated-output-stream-buffering* + (if (eq *communication-style* :spawn) :full :none) + "The buffering scheme that should be used for the output stream. +Valid values are :none, :line, and :full.") + +(defvar *coding-system* "iso-latin-1-unix") + +(defun start-server (port-file &key (style *communication-style*) + (dont-close *dont-close*) + (coding-system *coding-system*)) + "Start the server and write the listen port number to PORT-FILE. +This is the entry point for Emacs." + (flet ((start-server-aux () + (setup-server 0 (lambda (port) + (announce-server-port port-file port)) + style dont-close + (find-external-format-or-lose coding-system)))) + (if (eq style :spawn) + (initialize-multiprocessing #'start-server-aux) + (start-server-aux)))) + +(defun create-server (&key (port default-server-port) + (style *communication-style*) + (dont-close *dont-close*) + (coding-system *coding-system*)) + "Start a SWANK server on PORT running in STYLE. +If DONT-CLOSE is true then the listen socket will accept multiple +connections, otherwise it will be closed after the first." + (setup-server port #'simple-announce-function style dont-close + (find-external-format-or-lose coding-system))) + +(defun find-external-format-or-lose (coding-system) + (or (find-external-format coding-system) + (error "Unsupported coding system: ~s" coding-system))) + +(defparameter *loopback-interface* "127.0.0.1") + +(defun setup-server (port announce-fn style dont-close external-format) + (declare (type function announce-fn)) + (let* ((socket (create-socket *loopback-interface* port)) + (port (local-port socket))) + (funcall announce-fn port) + (flet ((serve () + (serve-connection socket style dont-close external-format))) + (ecase style + (:spawn + (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close)) + :name "Swank")) + ((:fd-handler :sigio) + (add-fd-handler socket (lambda () (serve)))) + ((nil) (loop do (serve) while dont-close))) + port))) + +(defun serve-connection (socket style dont-close external-format) + (let ((closed-socket-p nil)) + (unwind-protect + (let ((client (accept-authenticated-connection + socket :external-format external-format))) + (unless dont-close + (close-socket socket) + (setf closed-socket-p t)) + (let ((connection (create-connection client style))) + (run-hook *new-connection-hook* connection) + (push connection *connections*) + (serve-requests connection))) + (unless (or dont-close closed-socket-p) + (close-socket socket))))) + +(defun accept-authenticated-connection (&rest args) + (let ((new (apply #'accept-connection args)) + (success nil)) + (unwind-protect + (let ((secret (slime-secret))) + (when secret + (set-stream-timeout new 20) + (let ((first-val (decode-message new))) + (unless (and (stringp first-val) (string= first-val secret)) + (error "Incoming connection doesn't know the password.")))) + (set-stream-timeout new nil) + (setf success t)) + (unless success + (close new :abort t))) + new)) + +(defun slime-secret () + "Finds the magic secret from the user's home directory. Returns nil +if the file doesn't exist; otherwise the first line of the file." + (with-open-file (in + (merge-pathnames (user-homedir-pathname) #p".slime-secret") + :if-does-not-exist nil) + (and in (read-line in nil "")))) + +(defun serve-requests (connection) + "Read and process all requests on connections." + (funcall (connection.serve-requests connection) connection)) + +(defun announce-server-port (file port) + (with-open-file (s file + :direction :output + :if-exists :error + :if-does-not-exist :create) + (format s "~S~%" port)) + (simple-announce-function port)) + +(defun simple-announce-function (port) + (when *swank-debug-p* + (format *log-output* "~&;; Swank started at port: ~D.~%" port) + (force-output *log-output*))) + +(defun open-streams (connection) + "Return the 5 streams for IO redirection: +DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS" + (multiple-value-bind (output-fn dedicated-output) + (make-output-function connection) + (let ((input-fn + (lambda () + (with-connection (connection) + (with-simple-restart (abort-read + "Abort reading input from Emacs.") + (read-user-input-from-emacs)))))) + (multiple-value-bind (in out) (make-fn-streams input-fn output-fn) + (let ((out (or dedicated-output out))) + (let ((io (make-two-way-stream in out))) + (mapc #'make-stream-interactive (list in out io)) + (let ((repl-results + (make-output-stream-for-target connection :repl-result))) + (values dedicated-output in out io repl-results)))))))) + +(defun make-output-function (connection) + "Create function to send user output to Emacs. +This function may open a dedicated socket to send output. It +returns two values: the output function, and the dedicated +stream (or NIL if none was created)." + (if *use-dedicated-output-stream* + (let ((stream (open-dedicated-output-stream + (connection.socket-io connection)))) + (values (lambda (string) + (write-string string stream) + (force-output stream)) + stream)) + (values (lambda (string) + (with-connection (connection) + (with-simple-restart + (abort "Abort sending output to Emacs.") + (send-to-emacs `(:write-string ,string))))) + nil))) + +(defun make-output-function-for-target (connection target) + "Create a function to send user output to a specific TARGET in Emacs." + (lambda (string) + (with-connection (connection) + (with-simple-restart + (abort "Abort sending output to Emacs.") + (send-to-emacs `(:write-string ,string ,target)))))) + +(defun make-output-stream-for-target (connection target) + "Create a stream that sends output to a specific TARGET in Emacs." + (nth-value 1 (make-fn-streams + (lambda () + (error "Should never be called")) + (make-output-function-for-target connection target)))) + +(defun open-dedicated-output-stream (socket-io) + "Open a dedicated output connection to the Emacs on SOCKET-IO. +Return an output stream suitable for writing program output. + +This is an optimized way for Lisp to deliver output to Emacs." + (let ((socket (create-socket *loopback-interface* + *dedicated-output-stream-port*))) + (unwind-protect + (let ((port (local-port socket))) + (encode-message `(:open-dedicated-output-stream ,port) socket-io) + (let ((dedicated (accept-authenticated-connection + socket + :external-format + (or (ignore-errors + (stream-external-format socket-io)) + :default) + :buffering *dedicated-output-stream-buffering* + :timeout 30))) + (close-socket socket) + (setf socket nil) + dedicated)) + (when socket + (close-socket socket))))) + +(defvar *sldb-quit-restart* 'abort + "What restart should swank attempt to invoke when the user sldb-quits.") + +(defun handle-request (connection) + "Read and process one request. The processing is done in the extent +of the toplevel restart." + (assert (null *swank-state-stack*)) + (let ((*swank-state-stack* '(:handle-request))) + (with-connection (connection) + (with-simple-restart (abort "Return to SLIME's top level.") + (let ((*sldb-quit-restart* (find-restart 'abort))) + (read-from-emacs)))))) + +(defun current-socket-io () + (connection.socket-io *emacs-connection*)) + +(defun close-connection (c &optional condition backtrace) + (format *log-output* "~&;; swank:close-connection: ~A~%" condition) + (let ((cleanup (connection.cleanup c))) + (when cleanup + (funcall cleanup c))) + (close (connection.socket-io c)) + (when (connection.dedicated-output c) + (close (connection.dedicated-output c))) + (setf *connections* (remove c *connections*)) + (run-hook *connection-closed-hook* c) + (when (and condition (not (typep condition 'end-of-file))) + (finish-output *log-output*) + (format *log-output* "~&;; Event history start:~%") + (dump-event-history *log-output*) + (format *log-output* ";; Event history end.~%~ + ;; Backtrace:~%~{~A~%~}~ + ;; Connection to Emacs lost. [~%~ + ;; condition: ~A~%~ + ;; type: ~S~%~ + ;; encoding: ~A style: ~S dedicated: ~S]~%" + backtrace + (escape-non-ascii (safe-condition-message condition) ) + (type-of condition) + (ignore-errors (stream-external-format (connection.socket-io c))) + (connection.communication-style c) + *use-dedicated-output-stream*) + (finish-output *log-output*))) + +(defvar *debug-on-swank-error* nil + "When non-nil internal swank errors will drop to a + debugger (not an sldb buffer). Do not set this to T unless you + want to debug swank internals.") + +(defmacro with-reader-error-handler ((connection) &body body) + (let ((con (gensym)) + (blck (gensym))) + `(let ((,con ,connection)) + (block ,blck + (handler-bind ((swank-error + (lambda (e) + (if *debug-on-swank-error* + (invoke-debugger e) + (return-from ,blck + (close-connection + ,con + (swank-error.condition e) + (swank-error.backtrace e))))))) + (progn ,@body)))))) + +(defslimefun simple-break () + (with-simple-restart (continue "Continue from interrupt.") + (call-with-debugger-hook + #'swank-debugger-hook + (lambda () + (invoke-debugger + (make-condition 'simple-error + :format-control "Interrupt from Emacs"))))) + nil) + +;;;;;; Thread based communication + +(defvar *active-threads* '()) + +(defun read-loop (control-thread input-stream connection) + (with-reader-error-handler (connection) + (loop (send control-thread (decode-message input-stream))))) + +(defun dispatch-loop (socket-io connection) + (let ((*emacs-connection* connection)) + (handler-bind ((error (lambda (e) + (if *debug-on-swank-error* + (invoke-debugger e) + (return-from dispatch-loop + (close-connection connection e)))))) + (loop (dispatch-event (receive) socket-io))))) + +(defun repl-thread (connection) + (let ((thread (connection.repl-thread connection))) + (when (not thread) + (log-event "ERROR: repl-thread is nil")) + (assert thread) + (cond ((thread-alive-p thread) + thread) + (t + (setf (connection.repl-thread connection) + (spawn-repl-thread connection "new-repl-thread")))))) + +(defun find-worker-thread (id) + (etypecase id + ((member t) + (car *active-threads*)) + ((member :repl-thread) + (repl-thread *emacs-connection*)) + (fixnum + (find-thread id)))) + +(defun interrupt-worker-thread (id) + (let ((thread (or (find-worker-thread id) + (repl-thread *emacs-connection*)))) + (interrupt-thread thread #'simple-break))) + +(defun thread-for-evaluation (id) + "Find or create a thread to evaluate the next request." + (let ((c *emacs-connection*)) + (etypecase id + ((member t) + (spawn-worker-thread c)) + ((member :repl-thread) + (repl-thread c)) + (fixnum + (find-thread id))))) + +(defun spawn-worker-thread (connection) + (spawn (lambda () + (with-bindings *default-worker-thread-bindings* + (handle-request connection))) + :name "worker")) + +(defun spawn-repl-thread (connection name) + (spawn (lambda () + (with-bindings *default-worker-thread-bindings* + (repl-loop connection))) + :name name)) + +(defun dispatch-event (event socket-io) + "Handle an event triggered either by Emacs or within Lisp." + (log-event "DISPATCHING: ~S~%" event) + (destructure-case event + ((:emacs-rex form package thread-id id) + (let ((thread (thread-for-evaluation thread-id))) + (push thread *active-threads*) + (send thread `(eval-for-emacs ,form ,package ,id)))) + ((:return thread &rest args) + (let ((tail (member thread *active-threads*))) + (setq *active-threads* (nconc (ldiff *active-threads* tail) + (cdr tail)))) + (encode-message `(:return ,@args) socket-io)) + ((:emacs-interrupt thread-id) + (interrupt-worker-thread thread-id)) + (((:debug :debug-condition :debug-activate :debug-return) + thread &rest args) + (encode-message `(,(car event) ,(thread-id thread) ,@args) socket-io)) + ((:read-string thread &rest args) + (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io)) + ((:y-or-n-p thread &rest args) + (encode-message `(:y-or-n-p ,(thread-id thread) ,@args) socket-io)) + ((:read-aborted thread &rest args) + (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io)) + ((:emacs-return-string thread-id tag string) + (send (find-thread thread-id) `(take-input ,tag ,string))) + ((:eval thread &rest args) + (encode-message `(:eval ,(thread-id thread) ,@args) socket-io)) + ((:emacs-return thread-id tag value) + (send (find-thread thread-id) `(take-input ,tag ,value))) + (((:write-string :presentation-start :presentation-end + :new-package :new-features :ed :%apply :indentation-update + :eval-no-wait :background-message :inspect) + &rest _) + (declare (ignore _)) + (encode-message event socket-io)))) + +(defun spawn-threads-for-connection (connection) + (macrolet ((without-debugger-hook (&body body) + `(call-with-debugger-hook nil (lambda () ,@body)))) + (let* ((socket-io (connection.socket-io connection)) + (control-thread (spawn (lambda () + (without-debugger-hook + (dispatch-loop socket-io connection))) + :name "control-thread"))) + (setf (connection.control-thread connection) control-thread) + (let ((reader-thread (spawn (lambda () + (let ((go (receive))) + (assert (eq go 'accept-input))) + (without-debugger-hook + (read-loop control-thread socket-io + connection))) + :name "reader-thread")) + (repl-thread (spawn-repl-thread connection "repl-thread"))) + (setf (connection.repl-thread connection) repl-thread) + (setf (connection.reader-thread connection) reader-thread) + (send reader-thread 'accept-input) + connection)))) + +(defun cleanup-connection-threads (connection) + (let ((threads (list (connection.repl-thread connection) + (connection.reader-thread connection) + (connection.control-thread connection)))) + (dolist (thread threads) + (when (and thread + (thread-alive-p thread) + (not (equal (current-thread) thread))) + (kill-thread thread))))) + +(defun repl-loop (connection) + (loop (handle-request connection))) + +(defun process-available-input (stream fn) + (loop while (input-available-p stream) + do (funcall fn))) + +(defun input-available-p (stream) + ;; return true iff we can read from STREAM without waiting or if we + ;; hit EOF + (let ((c (read-char-no-hang stream nil :eof))) + (cond ((not c) nil) + ((eq c :eof) t) + (t + (unread-char c stream) + t)))) + +;;;;;; Signal driven IO + +(defun install-sigio-handler (connection) + (let ((client (connection.socket-io connection))) + (flet ((handler () + (cond ((null *swank-state-stack*) + (with-reader-error-handler (connection) + (process-available-input + client (lambda () (handle-request connection))))) + ((eq (car *swank-state-stack*) :read-next-form)) + (t (process-available-input client #'read-from-emacs))))) + (add-sigio-handler client #'handler) + (handler)))) + +(defun deinstall-sigio-handler (connection) + (remove-sigio-handlers (connection.socket-io connection))) + +;;;;;; SERVE-EVENT based IO + +(defun install-fd-handler (connection) + (let ((client (connection.socket-io connection))) + (flet ((handler () + (cond ((null *swank-state-stack*) + (with-reader-error-handler (connection) + (process-available-input + client (lambda () (handle-request connection))))) + ((eq (car *swank-state-stack*) :read-next-form)) + (t + (process-available-input client #'read-from-emacs))))) + ;;;; handle sigint + ;;(install-debugger-globally + ;; (lambda (c h) + ;; (with-reader-error-handler (connection) + ;; (block debugger + ;; (with-connection (connection) + ;; (swank-debugger-hook c h) + ;; (return-from debugger)) + ;; (abort))))) + (add-fd-handler client #'handler) + (handler)))) + +(defun deinstall-fd-handler (connection) + (remove-fd-handlers (connection.socket-io connection))) + +;;;;;; Simple sequential IO + +(defun simple-serve-requests (connection) + (unwind-protect + (with-simple-restart (close-connection "Close SLIME connection") + (with-reader-error-handler (connection) + (loop + (handle-request connection)))) + (close-connection connection))) + +(defun read-from-socket-io () + (let ((event (decode-message (current-socket-io)))) + (log-event "DISPATCHING: ~S~%" event) + (destructure-case event + ((:emacs-rex form package thread id) + (declare (ignore thread)) + `(eval-for-emacs ,form ,package ,id)) + ((:emacs-interrupt thread) + (declare (ignore thread)) + '(simple-break)) + ((:emacs-return-string thread tag string) + (declare (ignore thread)) + `(take-input ,tag ,string)) + ((:emacs-return thread tag value) + (declare (ignore thread)) + `(take-input ,tag ,value))))) + +(defun send-to-socket-io (event) + (log-event "DISPATCHING: ~S~%" event) + (flet ((send (o) + (without-interrupts + (encode-message o (current-socket-io))))) + (destructure-case event + (((:debug-activate :debug :debug-return :read-string :read-aborted + :y-or-n-p :eval) + thread &rest args) + (declare (ignore thread)) + (send `(,(car event) 0 ,@args))) + ((:return thread &rest args) + (declare (ignore thread)) + (send `(:return ,@args))) + (((:write-string :new-package :new-features :debug-condition + :presentation-start :presentation-end + :indentation-update :ed :%apply :eval-no-wait + :background-message :inspect) + &rest _) + (declare (ignore _)) + (send event))))) + +(defun initialize-streams-for-connection (connection) + (multiple-value-bind (dedicated in out io repl-results) + (open-streams connection) + (setf (connection.dedicated-output connection) dedicated + (connection.user-io connection) io + (connection.user-output connection) out + (connection.user-input connection) in + (connection.repl-results connection) repl-results) + connection)) + +(defun create-connection (socket-io style) + (let ((success nil)) + (unwind-protect + (let ((c (ecase style + (:spawn + (make-connection :socket-io socket-io + :read #'read-from-control-thread + :send #'send-to-control-thread + :serve-requests #'spawn-threads-for-connection + :cleanup #'cleanup-connection-threads)) + (:sigio + (make-connection :socket-io socket-io + :read #'read-from-socket-io + :send #'send-to-socket-io + :serve-requests #'install-sigio-handler + :cleanup #'deinstall-sigio-handler)) + (:fd-handler + (make-connection :socket-io socket-io + :read #'read-from-socket-io + :send #'send-to-socket-io + :serve-requests #'install-fd-handler + :cleanup #'deinstall-fd-handler)) + ((nil) + (make-connection :socket-io socket-io + :read #'read-from-socket-io + :send #'send-to-socket-io + :serve-requests #'simple-serve-requests))))) + (setf (connection.communication-style c) style) + (initialize-streams-for-connection c) + (setf success t) + c) + (unless success + (close socket-io :abort t))))) + + +;;;; IO to Emacs +;;; +;;; This code handles redirection of the standard I/O streams +;;; (`*standard-output*', etc) into Emacs. The `connection' structure +;;; contains the appropriate streams, so all we have to do is make the +;;; right bindings. + +;;;;; Global I/O redirection framework +;;; +;;; Optionally, the top-level global bindings of the standard streams +;;; can be assigned to be redirected to Emacs. When Emacs connects we +;;; redirect the streams into the connection, and they keep going into +;;; that connection even if more are established. If the connection +;;; handling the streams closes then another is chosen, or if there +;;; are no connections then we revert to the original (real) streams. +;;; +;;; It is slightly tricky to assign the global values of standard +;;; streams because they are often shadowed by dynamic bindings. We +;;; solve this problem by introducing an extra indirection via synonym +;;; streams, so that *STANDARD-INPUT* is a synonym stream to +;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current" +;;; variables, so they can always be assigned to affect a global +;;; change. + +(defvar *globally-redirect-io* nil + "When non-nil globally redirect all standard streams to Emacs.") + +;;;;; Global redirection setup + +(defvar *saved-global-streams* '() + "A plist to save and restore redirected stream objects. +E.g. the value for '*standard-output* holds the stream object +for *standard-output* before we install our redirection.") + +(defun setup-stream-indirection (stream-var &optional stream) + "Setup redirection scaffolding for a global stream variable. +Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro: + +1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'. + +2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as +*STANDARD-INPUT*. + +3. Assigns *STANDARD-INPUT* to a synonym stream pointing to +*CURRENT-STANDARD-INPUT*. + +This has the effect of making *CURRENT-STANDARD-INPUT* contain the +effective global value for *STANDARD-INPUT*. This way we can assign +the effective global value even when *STANDARD-INPUT* is shadowed by a +dynamic binding." + (let ((current-stream-var (prefixed-var '#:current stream-var)) + (stream (or stream (symbol-value stream-var)))) + ;; Save the real stream value for the future. + (setf (getf *saved-global-streams* stream-var) stream) + ;; Define a new variable for the effective stream. + ;; This can be reassigned. + (proclaim `(special ,current-stream-var)) + (set current-stream-var stream) + ;; Assign the real binding as a synonym for the current one. + (set stream-var (make-synonym-stream current-stream-var)))) + +(defun prefixed-var (prefix variable-symbol) + "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*" + (let ((basename (subseq (symbol-name variable-symbol) 1))) + (intern (format nil "*~A-~A" (string prefix) basename) :swank))) + +(defvar *standard-output-streams* + '(*standard-output* *error-output* *trace-output*) + "The symbols naming standard output streams.") + +(defvar *standard-input-streams* + '(*standard-input*) + "The symbols naming standard input streams.") + +(defvar *standard-io-streams* + '(*debug-io* *query-io* *terminal-io*) + "The symbols naming standard io streams.") + +(defun init-global-stream-redirection () + (when *globally-redirect-io* + (mapc #'setup-stream-indirection + (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*)))) + +(add-hook *after-init-hook* 'init-global-stream-redirection) + +(defun globally-redirect-io-to-connection (connection) + "Set the standard I/O streams to redirect to CONNECTION. +Assigns *CURRENT-<STREAM>* for all standard streams." + (dolist (o *standard-output-streams*) + (set (prefixed-var '#:current o) + (connection.user-output connection))) + ;; FIXME: If we redirect standard input to Emacs then we get the + ;; regular Lisp top-level trying to read from our REPL. + ;; + ;; Perhaps the ideal would be for the real top-level to run in a + ;; thread with local bindings for all the standard streams. Failing + ;; that we probably would like to inhibit it from reading while + ;; Emacs is connected. + ;; + ;; Meanwhile we just leave *standard-input* alone. + #+NIL + (dolist (i *standard-input-streams*) + (set (prefixed-var '#:current i) + (connection.user-input connection))) + (dolist (io *standard-io-streams*) + (set (prefixed-var '#:current io) + (connection.user-io connection)))) + +(defun revert-global-io-redirection () + "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams." + (dolist (stream-var (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*)) + (set (prefixed-var '#:current stream-var) + (getf *saved-global-streams* stream-var)))) + +;;;;; Global redirection hooks + +(defvar *global-stdio-connection* nil + "The connection to which standard I/O streams are globally redirected. +NIL if streams are not globally redirected.") + +(defun maybe-redirect-global-io (connection) + "Consider globally redirecting to a newly-established CONNECTION." + (when (and *globally-redirect-io* (null *global-stdio-connection*)) + (setq *global-stdio-connection* connection) + (globally-redirect-io-to-connection connection))) + +(defun update-redirection-after-close (closed-connection) + "Update redirection after a connection closes." + (check-type closed-connection connection) + (when (eq *global-stdio-connection* closed-connection) + (if (and (default-connection) *globally-redirect-io*) + ;; Redirect to another connection. + (globally-redirect-io-to-connection (default-connection)) + ;; No more connections, revert to the real streams. + (progn (revert-global-io-redirection) + (setq *global-stdio-connection* nil))))) + +(add-hook *new-connection-hook* 'maybe-redirect-global-io) +(add-hook *connection-closed-hook* 'update-redirection-after-close) + +;;;;; Redirection during requests +;;; +;;; We always redirect the standard streams to Emacs while evaluating +;;; an RPC. This is done with simple dynamic bindings. + +(defun call-with-redirected-io (connection function) + "Call FUNCTION with I/O streams redirected via CONNECTION." + (declare (type function function)) + (let* ((io (connection.user-io connection)) + (in (connection.user-input connection)) + (out (connection.user-output connection)) + (trace (or (connection.trace-output connection) out)) + (*standard-output* out) + (*error-output* out) + (*trace-output* trace) + (*debug-io* io) + (*query-io* io) + (*standard-input* in) + (*terminal-io* io)) + (funcall function))) + +(defun read-from-emacs () + "Read and process a request from Emacs." + (apply #'funcall (funcall (connection.read *emacs-connection*)))) + +(defun read-from-control-thread () + (receive)) + +(defun decode-message (stream) + "Read an S-expression from STREAM using the SLIME protocol." + (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*))) + (handler-bind ((error (lambda (c) (error (make-swank-error c))))) + (let* ((length (decode-message-length stream)) + (string (make-string length)) + (pos (read-sequence string stream))) + (assert (= pos length) () + "Short read: length=~D pos=~D" length pos) + (log-event "READ: ~S~%" string) + (read-form string))))) + +(defun decode-message-length (stream) + (let ((buffer (make-string 6))) + (dotimes (i 6) + (setf (aref buffer i) (read-char stream))) + (parse-integer buffer :radix #x10))) + +(defun read-form (string) + (with-standard-io-syntax + (let ((*package* *swank-io-package*)) + (read-from-string string)))) + +(defvar *slime-features* nil + "The feature list that has been sent to Emacs.") + +(defun send-to-emacs (object) + "Send OBJECT to Emacs." + (funcall (connection.send *emacs-connection*) object)) + +(defun send-oob-to-emacs (object) + (send-to-emacs object)) + +(defun send-to-control-thread (object) + (send (connection.control-thread *emacs-connection*) object)) + +(defun encode-message (message stream) + (let* ((string (prin1-to-string-for-emacs message)) + (length (length string))) + (log-event "WRITE: ~A~%" string) + (let ((*print-pretty* nil)) + (format stream "~6,'0x" length)) + (write-string string stream) + ;;(terpri stream) + (finish-output stream))) + +(defun prin1-to-string-for-emacs (object) + (with-standard-io-syntax + (let ((*print-case* :downcase) + (*print-readably* nil) + (*print-pretty* nil) + (*package* *swank-io-package*)) + (prin1-to-string object)))) + +(defun force-user-output () + (force-output (connection.user-io *emacs-connection*)) + (finish-output (connection.user-output *emacs-connection*))) + +(defun clear-user-input () + (clear-input (connection.user-input *emacs-connection*))) + +(defvar *read-input-catch-tag* 0) + +(defun intern-catch-tag (tag) + ;; fixnums aren't eq in ABCL, so we use intern to create tags + (intern (format nil "~D" tag) :swank)) + +(defun read-user-input-from-emacs () + (let ((tag (incf *read-input-catch-tag*))) + (force-output) + (send-to-emacs `(:read-string ,(current-thread) ,tag)) + (let ((ok nil)) + (unwind-protect + (prog1 (catch (intern-catch-tag tag) + (loop (read-from-emacs))) + (setq ok t)) + (unless ok + (send-to-emacs `(:read-aborted ,(current-thread) ,tag))))))) + +(defun y-or-n-p-in-emacs (format-string &rest arguments) + "Like y-or-n-p, but ask in the Emacs minibuffer." + (let ((tag (incf *read-input-catch-tag*)) + (question (apply #'format nil format-string arguments))) + (force-output) + (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question)) + (catch (intern-catch-tag tag) + (loop (read-from-emacs))))) + +(defslimefun take-input (tag input) + "Return the string INPUT to the continuation TAG." + (throw (intern-catch-tag tag) input)) + +(defun process-form-for-emacs (form) + "Returns a string which emacs will read as equivalent to +FORM. FORM can contain lists, strings, characters, symbols and +numbers. + +Characters are converted emacs' ?<char> notaion, strings are left +as they are (except for espacing any nested \" chars, numbers are +printed in base 10 and symbols are printed as their symbol-name +converted to lower case." + (etypecase form + (string (format nil "~S" form)) + (cons (format nil "(~A . ~A)" + (process-form-for-emacs (car form)) + (process-form-for-emacs (cdr form)))) + (character (format nil "?~C" form)) + (symbol (concatenate 'string (when (eq (symbol-package form) + #.(find-package "KEYWORD")) + ":") + (string-downcase (symbol-name form)))) + (number (let ((*print-base* 10)) + (princ-to-string form))))) + +(defun eval-in-emacs (form &optional nowait) + "Eval FORM in Emacs." + (cond (nowait + (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form)))) + (t + (force-output) + (let* ((tag (incf *read-input-catch-tag*)) + (value (catch (intern-catch-tag tag) + (send-to-emacs + `(:eval ,(current-thread) ,tag + ,(process-form-for-emacs form))) + (loop (read-from-emacs))))) + (destructure-case value + ((:ok value) value) + ((:abort) (abort))))))) + +(defvar *swank-wire-protocol-version* nil + "The version of the swank/slime communication protocol.") + +(defslimefun connection-info () + "Return a key-value list of the form: +\(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION) +PID: is the process-id of Lisp process (or nil, depending on the STYLE) +STYLE: the communication style +LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION) +FEATURES: a list of keywords +PACKAGE: a list (&key NAME PROMPT) +VERSION: the protocol version" + (setq *slime-features* *features*) + `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*) + :lisp-implementation (:type ,(lisp-implementation-type) + :name ,(lisp-implementation-type-name) + :version ,(lisp-implementation-version)) + :machine (:instance ,(machine-instance) + :type ,(machine-type) + :version ,(machine-version)) + :features ,(features-for-emacs) + :package (:name ,(package-name *package*) + :prompt ,(package-string-for-prompt *package*)) + :version ,*swank-wire-protocol-version*)) + +(defslimefun io-speed-test (&optional (n 5000) (m 1)) + (let* ((s *standard-output*) + (*trace-output* (make-broadcast-stream s *log-output*))) + (time (progn + (dotimes (i n) + (format s "~D abcdefghijklm~%" i) + (when (zerop (mod n m)) + (force-output s))) + (finish-output s) + (when *emacs-connection* + (eval-in-emacs '(message "done."))))) + (terpri *trace-output*) + (finish-output *trace-output*) + nil)) + + +;;;; Reading and printing + +(defmacro define-special (name doc) + "Define a special variable NAME with doc string DOC. +This is like defvar, but NAME will not be initialized." + `(progn + (defvar ,name) + (setf (documentation ',name 'variable) ,doc))) + +(define-special *buffer-package* + "Package corresponding to slime-buffer-package. + +EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime +buffer are best read in this package. See also FROM-STRING and TO-STRING.") + +(define-special *buffer-readtable* + "Readtable associated with the current buffer") + +(defmacro with-buffer-syntax ((&rest _) &body body) + "Execute BODY with appropriate *package* and *readtable* bindings. + +This should be used for code that is conceptionally executed in an +Emacs buffer." + (destructuring-bind () _ + `(call-with-buffer-syntax (lambda () ,@body)))) + +(defun call-with-buffer-syntax (fun) + (let ((*package* *buffer-package*)) + ;; Don't shadow *readtable* unnecessarily because that prevents + ;; the user from assigning to it. + (if (eq *readtable* *buffer-readtable*) + (call-with-syntax-hooks fun) + (let ((*readtable* *buffer-readtable*)) + (call-with-syntax-hooks fun))))) + +(defun to-string (object) + "Write OBJECT in the *BUFFER-PACKAGE*. +The result may not be readable. Handles problems with PRINT-OBJECT methods +gracefully." + (with-buffer-syntax () + (let ((*print-readably* nil)) + (handler-case + (prin1-to-string object) + (error () + (with-output-to-string (s) + (print-unreadable-object (object s :type t :identity t) + (princ "<<error printing object>>" s)))))))) + +(defun from-string (string) + "Read string in the *BUFFER-PACKAGE*" + (with-buffer-syntax () + (let ((*read-suppress* nil)) + (read-from-string string)))) + +;; FIXME: deal with #\| etc. hard to do portably. +(defun tokenize-symbol (string) + "STRING is interpreted as the string representation of a symbol +and is tokenized accordingly. The result is returned in three +values: The package identifier part, the actual symbol identifier +part, and a flag if the STRING represents a symbol that is +internal to the package identifier part. (Notice that the flag is +also true with an empty package identifier part, as the STRING is +considered to represent a symbol internal to some current package.)" + (let ((package (let ((pos (position #\: string))) + (if pos (subseq string 0 pos) nil))) + (symbol (let ((pos (position #\: string :from-end t))) + (if pos (subseq string (1+ pos)) string))) + (internp (not (= (count #\: string) 1)))) + (values symbol package internp))) + +(defun tokenize-symbol-thoroughly (string) + "This version of TOKENIZE-SYMBOL handles escape characters." + (let ((package nil) + (token (make-array (length string) :element-type 'character + :fill-pointer 0)) + (backslash nil) + (vertical nil) + (internp nil)) + (loop for char across string + do (cond + (backslash + (vector-push-extend char token) + (setq backslash nil)) + ((char= char #\\) ; Quotes next character, even within |...| + (setq backslash t)) + ((char= char #\|) + (setq vertical t)) + (vertical + (vector-push-extend char token)) + ((char= char #\:) + (if package + (setq internp t) + (setq package token + token (make-array (length string) + :element-type 'character + :fill-pointer 0)))) + (t + (vector-push-extend (casify-char char) token)))) + (values token package (or (not package) internp)))) + +(defun untokenize-symbol (package-name internal-p symbol-name) + "The inverse of TOKENIZE-SYMBOL. + + (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\" + (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\" + (untokenize-symbol nil nil \"foo\") ==> \"foo\" +" + (cond ((not package-name) symbol-name) + (internal-p (cat package-name "::" symbol-name)) + (t (cat package-name ":" symbol-name)))) + +(defun casify-char (char) + "Convert CHAR accoring to readtable-case." + (ecase (readtable-case *readtable*) + (:preserve char) + (:upcase (char-upcase char)) + (:downcase (char-downcase char)) + (:invert (if (upper-case-p char) + (char-downcase char) + (char-upcase char))))) + +(defun parse-symbol (string &optional (package *package*)) + "Find the symbol named STRING. +Return the symbol and a flag indicating whether the symbols was found." + (multiple-value-bind (sname pname) (tokenize-symbol-thoroughly string) + (let ((package (cond ((string= pname "") keyword-package) + (pname (find-package pname)) + (t package)))) + (if package + (multiple-value-bind (symbol flag) (find-symbol sname package) + (values symbol flag sname package)) + (values nil nil nil nil))))) + +(defun parse-symbol-or-lose (string &optional (package *package*)) + (multiple-value-bind (symbol status) (parse-symbol string package) + (if status + (values symbol status) + (error "Unknown symbol: ~A [in ~A]" string package)))) + +;; FIXME: interns the name +(defun parse-package (string) + "Find the package named STRING. +Return the package or nil." + (multiple-value-bind (name pos) + (if (zerop (length string)) + (values :|| 0) + (let ((*package* *swank-io-package*)) + (ignore-errors (read-from-string string)))) + (and name + (or (symbolp name) + (stringp name)) + (= (length string) pos) + (find-package name)))) + +(defun unparse-name (string) + "Print the name STRING according to the current printer settings." + ;; this is intended for package or symbol names + (subseq (prin1-to-string (make-symbol string)) 2)) + +(defun guess-package (string) + "Guess which package corresponds to STRING. +Return nil if no package matches." + (or (find-package string) + (parse-package string) + (if (find #\! string) ; for SBCL + (guess-package (substitute #\- #\! string))))) + +(defvar *readtable-alist* (default-readtable-alist) + "An alist mapping package names to readtables.") + +(defun guess-buffer-readtable (package-name) + (let ((package (guess-package package-name))) + (or (and package + (cdr (assoc (package-name package) *readtable-alist* + :test #'string=))) + *readtable*))) + + +;;;; Evaluation + +(defvar *pending-continuations* '() + "List of continuations for Emacs. (thread local)") + +(defun guess-buffer-package (string) + "Return a package for STRING. +Fall back to the the current if no such package exists." + (or (and string (guess-package string)) + *package*)) + +(defun eval-for-emacs (form buffer-package id) + "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM. +Return the result to the continuation ID. +Errors are trapped and invoke our debugger." + (call-with-debugger-hook + #'swank-debugger-hook + (lambda () + (let (ok result) + (unwind-protect + (let ((*buffer-package* (guess-buffer-package buffer-package)) + (*buffer-readtable* (guess-buffer-readtable buffer-package)) + (*pending-continuations* (cons id *pending-continuations*))) + (check-type *buffer-package* package) + (check-type *buffer-readtable* readtable) + ;; APPLY would be cleaner than EVAL. + ;;(setq result (apply (car form) (cdr form))) + (setq result (eval form)) + (run-hook *pre-reply-hook*) + (finish-output) + (setq ok t)) + (force-user-output) + (send-to-emacs `(:return ,(current-thread) + ,(if ok + `(:ok ,result) + `(:abort)) + ,id))))))) + +(defvar *echo-area-prefix* "=> " + "A prefix that `format-values-for-echo-area' should use.") + +(defun format-values-for-echo-area (values) + (with-buffer-syntax () + (let ((*print-readably* nil)) + (cond ((null values) "; No value") + ((and (length= values 1) (integerp (car values))) + (let ((i (car values))) + (format nil "~A~D (#x~X, #o~O, #b~B)" + *echo-area-prefix* i i i i))) + (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values)))))) + +(defslimefun interactive-eval (string) + (with-buffer-syntax () + (let ((values (multiple-value-list (eval (from-string string))))) + (fresh-line) + (finish-output) + (format-values-for-echo-area values)))) + +(defslimefun eval-and-grab-output (string) + (with-buffer-syntax () + (let* ((s (make-string-output-stream)) + (*standard-output* s) + (values (multiple-value-list (eval (from-string string))))) + (list (get-output-stream-string s) + (format nil "~{~S~^~%~}" values))))) + +(defun eval-region (string) + "Evaluate STRING. +Return the results of the last form as a list and as secondary value the +last form." + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (return (values values -))) + (setq - form) + (setq values (multiple-value-list (eval form))) + (finish-output)))))) + +(defslimefun interactive-eval-region (string) + (with-buffer-syntax () + (format-values-for-echo-area (eval-region string)))) + +(defslimefun re-evaluate-defvar (form) + (with-buffer-syntax () + (let ((form (read-from-string form))) + (destructuring-bind (dv name &optional value doc) form + (declare (ignore value doc)) + (assert (eq dv 'defvar)) + (makunbound name) + (prin1-to-string (eval form)))))) + +(defvar *swank-pprint-bindings* + `((*print-pretty* . t) + (*print-level* . nil) + (*print-length* . nil) + (*print-circle* . t) + (*print-gensym* . t) + (*print-readably* . nil)) + "A list of variables bindings during pretty printing. +Used by pprint-eval.") + +(defun swank-pprint (list) + "Bind some printer variables and pretty print each object in LIST." + (with-buffer-syntax () + (with-bindings *swank-pprint-bindings* + (cond ((null list) "; No value") + (t (with-output-to-string (*standard-output*) + (dolist (o list) + (pprint o) + (terpri)))))))) + +(defslimefun pprint-eval (string) + (with-buffer-syntax () + (swank-pprint (multiple-value-list (eval (read-from-string string)))))) + +(defslimefun set-package (name) + "Set *package* to the package named NAME. +Return the full package-name and the string to use in the prompt." + (let ((p (guess-package name))) + (assert (packagep p)) + (setq *package* p) + (list (package-name p) (package-string-for-prompt p)))) + +;;;;; Listener eval + +(defvar *listener-eval-function* 'repl-eval) + +(defslimefun listener-eval (string) + (funcall *listener-eval-function* string)) + +(defvar *send-repl-results-function* 'send-repl-results-to-emacs) + +(defun repl-eval (string) + (clear-user-input) + (with-buffer-syntax () + (track-package + (lambda () + (multiple-value-bind (values last-form) (eval-region string) + (setq *** ** ** * * (car values) + /// // // / / values + +++ ++ ++ + + last-form) + (funcall *send-repl-results-function* values))))) + nil) + +(defun track-package (fun) + (let ((p *package*)) + (unwind-protect (funcall fun) + (unless (eq *package* p) + (send-to-emacs (list :new-package (package-name *package*) + (package-string-for-prompt *package*))))))) + +(defun send-repl-results-to-emacs (values) + (fresh-line) + (finish-output) + (if (null values) + (send-to-emacs `(:write-string "; No value" :repl-result)) + (dolist (v values) + (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline) + :repl-result))))) + +(defun cat (&rest strings) + "Concatenate all arguments and make the result a string." + (with-output-to-string (out) + (dolist (s strings) + (etypecase s + (string (write-string s out)) + (character (write-char s out)))))) + +(defun package-string-for-prompt (package) + "Return the shortest nickname (or canonical name) of PACKAGE." + (unparse-name + (or (canonical-package-nickname package) + (auto-abbreviated-package-name package) + (shortest-package-nickname package)))) + +(defun canonical-package-nickname (package) + "Return the canonical package nickname, if any, of PACKAGE." + (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames* + :test #'string=)))) + (and name (string name)))) + +(defun auto-abbreviated-package-name (package) + "Return an abbreviated 'name' for PACKAGE. + +N.B. this is not an actual package name or nickname." + (when *auto-abbreviate-dotted-packages* + (let ((last-dot (position #\. (package-name package) :from-end t))) + (when last-dot (subseq (package-name package) (1+ last-dot)))))) + +(defun shortest-package-nickname (package) + "Return the shortest nickname (or canonical name) of PACKAGE." + (loop for name in (cons (package-name package) (package-nicknames package)) + for shortest = name then (if (< (length name) (length shortest)) + name + shortest) + finally (return shortest))) + +(defslimefun ed-in-emacs (&optional what) + "Edit WHAT in Emacs. + +WHAT can be: + A pathname or a string, + A list (PATHNAME-OR-STRING LINE [COLUMN]), + A function name (symbol or cons), + NIL. + +Returns true if it actually called emacs, or NIL if not." + (flet ((pathname-or-string-p (thing) + (or (pathnamep thing) (typep thing 'string)))) + (let ((target + (cond ((and (listp what) (pathname-or-string-p (first what))) + (cons (canonicalize-filename (car what)) (cdr what))) + ((pathname-or-string-p what) + (canonicalize-filename what)) + ((symbolp what) what) + ((consp what) what) + (t (return-from ed-in-emacs nil))))) + (cond + (*emacs-connection* (send-oob-to-emacs `(:ed ,target))) + ((default-connection) + (with-connection ((default-connection)) + (send-oob-to-emacs `(:ed ,target)))) + (t nil))))) + +(defslimefun inspect-in-emacs (what) + "Inspect WHAT in Emacs." + (flet ((send-it () + (with-buffer-syntax () + (reset-inspector) + (send-oob-to-emacs `(:inspect ,(inspect-object what)))))) + (cond + (*emacs-connection* + (send-it)) + ((default-connection) + (with-connection ((default-connection)) + (send-it)))) + what)) + +(defslimefun value-for-editing (form) + "Return a readable value of FORM for editing in Emacs. +FORM is expected, but not required, to be SETF'able." + ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005) + (with-buffer-syntax () + (prin1-to-string (eval (read-from-string form))))) + +(defslimefun commit-edited-value (form value) + "Set the value of a setf'able FORM to VALUE. +FORM and VALUE are both strings from Emacs." + (with-buffer-syntax () + (eval `(setf ,(read-from-string form) + ,(read-from-string (concatenate 'string "`" value)))) + t)) + +(defun background-message (format-string &rest args) + "Display a message in Emacs' echo area. + +Use this function for informative messages only. The message may even +be dropped, if we are too busy with other things." + (when *emacs-connection* + (send-to-emacs `(:background-message + ,(apply #'format nil format-string args))))) + + +;;;; Debugger + +(defun swank-debugger-hook (condition hook) + "Debugger function for binding *DEBUGGER-HOOK*. +Sends a message to Emacs declaring that the debugger has been entered, +then waits to handle further requests from Emacs. Eventually returns +after Emacs causes a restart to be invoked." + (declare (ignore hook)) + (cond (*emacs-connection* + (debug-in-emacs condition)) + ((default-connection) + (with-connection ((default-connection)) + (debug-in-emacs condition))))) + +(defvar *global-debugger* t + "Non-nil means the Swank debugger hook will be installed globally.") + +(add-hook *new-connection-hook* 'install-debugger) +(defun install-debugger (connection) + (declare (ignore connection)) + (when *global-debugger* + (install-debugger-globally #'swank-debugger-hook))) + +;;;;; Debugger loop +;;; +;;; These variables are dynamically bound during debugging. +;;; +(defvar *swank-debugger-condition* nil + "The condition being debugged.") + +(defvar *sldb-level* 0 + "The current level of recursive debugging.") + +(defvar *sldb-initial-frames* 20 + "The initial number of backtrace frames to send to Emacs.") + +(defvar *sldb-restarts* nil + "The list of currenlty active restarts.") + +(defvar *sldb-stepping-p* nil + "True during execution of a step command.") + +(defun debug-in-emacs (condition) + (let ((*swank-debugger-condition* condition) + (*sldb-restarts* (compute-sane-restarts condition)) + (*package* (or (and (boundp '*buffer-package*) + (symbol-value '*buffer-package*)) + *package*)) + (*sldb-level* (1+ *sldb-level*)) + (*sldb-stepping-p* nil) + (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*))) + (force-user-output) + (call-with-debugging-environment + (lambda () + (with-bindings *sldb-printer-bindings* + (sldb-loop *sldb-level*)))))) + +(defun sldb-loop (level) + (unwind-protect + (catch 'sldb-enter-default-debugger + (send-to-emacs + (list* :debug (current-thread) level + (debugger-info-for-emacs 0 *sldb-initial-frames*))) + (loop (catch 'sldb-loop-catcher + (with-simple-restart (abort "Return to sldb level ~D." level) + (send-to-emacs (list :debug-activate (current-thread) + level)) + (handler-bind ((sldb-condition #'handle-sldb-condition)) + (read-from-emacs)))))) + (send-to-emacs `(:debug-return + ,(current-thread) ,level ,*sldb-stepping-p*)))) + +(defun handle-sldb-condition (condition) + "Handle an internal debugger condition. +Rather than recursively debug the debugger (a dangerous idea!), these +conditions are simply reported." + (let ((real-condition (original-condition condition))) + (send-to-emacs `(:debug-condition ,(current-thread) + ,(princ-to-string real-condition)))) + (throw 'sldb-loop-catcher nil)) + +(defun safe-condition-message (condition) + "Safely print condition to a string, handling any errors during +printing." + (let ((*print-pretty* t)) + (handler-case + (format-sldb-condition condition) + (error (cond) + ;; Beware of recursive errors in printing, so only use the condition + ;; if it is printable itself: + (format nil "Unable to display error condition~@[: ~A~]" + (ignore-errors (princ-to-string cond))))))) + +(defun debugger-condition-for-emacs () + (list (safe-condition-message *swank-debugger-condition*) + (format nil " [Condition of type ~S]" + (type-of *swank-debugger-condition*)) + (condition-extras *swank-debugger-condition*))) + +(defun format-restarts-for-emacs () + "Return a list of restarts for *swank-debugger-condition* in a +format suitable for Emacs." + (let ((*print-right-margin* most-positive-fixnum)) + (loop for restart in *sldb-restarts* + collect (list (princ-to-string (restart-name restart)) + (princ-to-string restart))))) + + +;;;;; SLDB entry points + +(defslimefun sldb-break-with-default-debugger () + "Invoke the default debugger by returning from our debugger-loop." + (throw 'sldb-enter-default-debugger nil)) + +(defslimefun backtrace (start end) + "Return a list ((I FRAME) ...) of frames from START to END. +I is an integer describing and FRAME a string." + (loop for frame in (compute-backtrace start end) + for i from start + collect (list i (with-output-to-string (stream) + (handler-case + (print-frame frame stream) + (t () + (format stream "[error printing frame]"))))))) + +(defslimefun debugger-info-for-emacs (start end) + "Return debugger state, with stack frames from START to END. +The result is a list: + (condition ({restart}*) ({stack-frame}*) (cont*)) +where + condition ::= (description type [extra]) + restart ::= (name description) + stack-frame ::= (number description) + extra ::= (:references and other random things) + cont ::= continutation +condition---a pair of strings: message, and type. If show-source is +not nil it is a frame number for which the source should be displayed. + +restart---a pair of strings: restart name, and description. + +stack-frame---a number from zero (the top), and a printed +representation of the frame's call. + +continutation---the id of a pending Emacs continuation. + +Below is an example return value. In this case the condition was a +division by zero (multi-line description), and only one frame is being +fetched (start=0, end=1). + + ((\"Arithmetic error DIVISION-BY-ZERO signalled. +Operation was KERNEL::DIVISION, operands (1 0).\" + \"[Condition of type DIVISION-BY-ZERO]\") + ((\"ABORT\" \"Return to Slime toplevel.\") + (\"ABORT\" \"Return to Top-Level.\")) + ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\")) + (4))" + (list (debugger-condition-for-emacs) + (format-restarts-for-emacs) + (backtrace start end) + *pending-continuations*)) + +(defun nth-restart (index) + (nth index *sldb-restarts*)) + +(defslimefun invoke-nth-restart (index) + (invoke-restart-interactively (nth-restart index))) + +(defslimefun sldb-abort () + (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) + +(defslimefun sldb-continue () + (continue)) + +(defslimefun throw-to-toplevel () + "Invoke the ABORT-REQUEST restart abort an RPC from Emacs. +If we are not evaluating an RPC then ABORT instead." + (let ((restart (find-restart *sldb-quit-restart*))) + (cond (restart (invoke-restart restart)) + (t (format nil + "Restart not found: ~a" + *sldb-quit-restart*))))) + +(defslimefun invoke-nth-restart-for-emacs (sldb-level n) + "Invoke the Nth available restart. +SLDB-LEVEL is the debug level when the request was made. If this +has changed, ignore the request." + (when (= sldb-level *sldb-level*) + (invoke-nth-restart n))) + +(defun wrap-sldb-vars (form) + `(let ((*sldb-level* ,*sldb-level*)) + ,form)) + +(defslimefun eval-string-in-frame (string index) + (to-string (eval-in-frame (wrap-sldb-vars (from-string string)) + index))) + +(defslimefun pprint-eval-string-in-frame (string index) + (swank-pprint + (multiple-value-list + (eval-in-frame (wrap-sldb-vars (from-string string)) index)))) + +(defslimefun frame-locals-for-emacs (index) + "Return a property list ((&key NAME ID VALUE) ...) describing +the local variables in the frame INDEX." + (mapcar (lambda (frame-locals) + (destructuring-bind (&key name id value) frame-locals + (list :name (prin1-to-string name) :id id + :value (to-string value)))) + (frame-locals index))) + +(defslimefun frame-catch-tags-for-emacs (frame-index) + (mapcar #'to-string (frame-catch-tags frame-index))) + +(defslimefun sldb-disassemble (index) + (with-output-to-string (*standard-output*) + (disassemble-frame index))) + +(defslimefun sldb-return-from-frame (index string) + (let ((form (from-string string))) + (to-string (multiple-value-list (return-from-frame index form))))) + +(defslimefun sldb-break (name) + (with-buffer-syntax () + (sldb-break-at-start (read-from-string name)))) + +(defmacro define-stepper-function (name backend-function-name) + `(defslimefun ,name (frame) + (cond ((sldb-stepper-condition-p *swank-debugger-condition*) + (setq *sldb-stepping-p* t) + (,backend-function-name)) + ((find-restart 'continue) + (activate-stepping frame) + (setq *sldb-stepping-p* t) + (continue)) + (t + (error "Not currently single-stepping, and no continue restart available."))))) + +(define-stepper-function sldb-step sldb-step-into) +(define-stepper-function sldb-next sldb-step-next) +(define-stepper-function sldb-out sldb-step-out) + + +;;;; Compilation Commands. + +(defvar *compiler-notes* '() + "List of compiler notes for the last compilation unit.") + +(defun clear-compiler-notes () + (setf *compiler-notes* '())) + +(defun canonicalize-filename (filename) + (namestring (truename filename))) + +(defslimefun compiler-notes-for-emacs () + "Return the list of compiler notes for the last compilation unit." + (reverse *compiler-notes*)) + +(defun measure-time-interval (fn) + "Call FN and return the first return value and the elapsed time. +The time is measured in microseconds." + (declare (type function fn)) + (let ((before (get-internal-real-time))) + (values + (funcall fn) + (* (- (get-internal-real-time) before) + (/ 1000000 internal-time-units-per-second))))) + +(defun record-note-for-condition (condition) + "Record a note for a compiler-condition." + (push (make-compiler-note condition) *compiler-notes*)) + +(defun make-compiler-note (condition) + "Make a compiler note data structure from a compiler-condition." + (declare (type compiler-condition condition)) + (list* :message (message condition) + :severity (severity condition) + :location (location condition) + :references (references condition) + (let ((s (short-message condition))) + (if s (list :short-message s))))) + +(defun swank-compiler (function) + (clear-compiler-notes) + (multiple-value-bind (result usecs) + (with-simple-restart (abort "Abort SLIME compilation.") + (handler-bind ((compiler-condition #'record-note-for-condition)) + (measure-time-interval function))) + ;; WITH-SIMPLE-RESTART returns (values nil t) if its restart is invoked; + ;; unfortunately the SWANK protocol doesn't support returning multiple + ;; values, so we gotta convert it explicitely to a list in either case. + (if (and (not result) (eq usecs 't)) + (list nil nil) + (list (to-string result) + (format nil "~,2F" (/ usecs 1000000.0)))))) + +(defslimefun compile-file-for-emacs (filename load-p) + "Compile FILENAME and, when LOAD-P, load the result. +Record compiler notes signalled as `compiler-condition's." + (with-buffer-syntax () + (let ((*compile-print* nil)) + (swank-compiler + (lambda () + (swank-compile-file filename load-p + (or (guess-external-format filename) + :default))))))) + +(defslimefun compile-string-for-emacs (string buffer position directory) + "Compile STRING (exerpted from BUFFER at POSITION). +Record compiler notes signalled as `compiler-condition's." + (with-buffer-syntax () + (swank-compiler + (lambda () + (let ((*compile-print* nil) (*compile-verbose* t)) + (swank-compile-string string :buffer buffer :position position + :directory directory)))))) + +(defun file-newer-p (new-file old-file) + "Returns true if NEW-FILE is newer than OLD-FILE." + (> (file-write-date new-file) (file-write-date old-file))) + +(defun requires-compile-p (source-file) + (let ((fasl-file (probe-file (compile-file-pathname source-file)))) + (or (not fasl-file) + (file-newer-p source-file fasl-file)))) + +(defslimefun compile-file-if-needed (filename loadp) + (cond ((requires-compile-p filename) + (compile-file-for-emacs filename loadp)) + (loadp + (load (compile-file-pathname filename)) + nil))) + + +;;;; Loading + +(defslimefun load-file (filename) + (to-string (load filename))) + +(defslimefun load-file-set-package (filename &optional package) + (load-file filename) + (if package + (set-package package))) + + +;;;;; swank-require + +(defslimefun swank-require (module &optional filename) + "Load the module MODULE." + (require module (or filename (module-filename module))) + nil) + +(defvar *find-module* 'find-module + "Pluggable function to locate modules. +The function receives a module name as argument and should return +the filename of the module (or nil if the file doesn't exist).") + +(defun module-filename (module) + "Return the filename for the module MODULE." + (or (funcall *find-module* module) + (error "Can't locate module: ~s" module))) + +;;;;;; Simple *find-module* function. + +(defun merged-directory (dirname defaults) + (pathname-directory + (merge-pathnames + (make-pathname :directory `(:relative ,dirname) :defaults defaults) + defaults))) + +(defvar *load-path* + (list (make-pathname :directory (merged-directory "contrib" *load-truename*) + :name nil :type nil :version nil + :defaults *load-truename*)) + "A list of directories to search for modules.") + +(defun module-canditates (name dir) + (list (compile-file-pathname (make-pathname :name name :defaults dir)) + (make-pathname :name name :type "lisp" :defaults dir))) + +(defun find-module (module) + (let ((name (string-downcase module))) + (some (lambda (dir) (some #'probe-file (module-canditates name dir))) + *load-path*))) + + +;;;; Macroexpansion + +(defvar *macroexpand-printer-bindings* + '((*print-circle* . nil) + (*print-pretty* . t) + (*print-escape* . t) + (*print-lines* . nil) + (*print-level* . nil) + (*print-length* . nil))) + +(defun apply-macro-expander (expander string) + (with-buffer-syntax () + (with-bindings *macroexpand-printer-bindings* + (prin1-to-string (funcall expander (from-string string)))))) + +(defslimefun swank-macroexpand-1 (string) + (apply-macro-expander #'macroexpand-1 string)) + +(defslimefun swank-macroexpand (string) + (apply-macro-expander #'macroexpand string)) + +(defslimefun swank-macroexpand-all (string) + (apply-macro-expander #'macroexpand-all string)) + +(defslimefun swank-compiler-macroexpand-1 (string) + (apply-macro-expander #'compiler-macroexpand-1 string)) + +(defslimefun swank-compiler-macroexpand (string) + (apply-macro-expander #'compiler-macroexpand string)) + +(defslimefun disassemble-symbol (name) + (with-buffer-syntax () + (with-output-to-string (*standard-output*) + (let ((*print-readably* nil)) + (disassemble (fdefinition (from-string name))))))) + + +;;;; Simple completion + +(defslimefun simple-completions (string buffer-package) + "Return a list of completions for the string STRING." + (let ((strings (all-completions string buffer-package #'prefix-match-p))) + (list strings (longest-common-prefix strings)))) + +(defun all-completions (string buffer-package test) + (multiple-value-bind (name pname intern) (tokenize-symbol string) + (let* ((extern (and pname (not intern))) + (pack (cond ((equal pname "") keyword-package) + ((not pname) (guess-buffer-package buffer-package)) + (t (guess-package pname)))) + (test (lambda (sym) (funcall test name (unparse-symbol sym)))) + (syms (and pack (matching-symbols pack extern test)))) + (format-completion-set (mapcar #'unparse-symbol syms) intern pname)))) + +(defun matching-symbols (package external test) + (let ((test (if external + (lambda (s) + (and (symbol-external-p s package) + (funcall test s))) + test)) + (result '())) + (do-symbols (s package) + (when (funcall test s) + (push s result))) + (remove-duplicates result))) + +(defun unparse-symbol (symbol) + (let ((*print-case* (case (readtable-case *readtable*) + (:downcase :upcase) + (t :downcase)))) + (unparse-name (symbol-name symbol)))) + +(defun prefix-match-p (prefix string) + "Return true if PREFIX is a prefix of STRING." + (not (mismatch prefix string :end2 (min (length string) (length prefix))))) + +(defun longest-common-prefix (strings) + "Return the longest string that is a common prefix of STRINGS." + (if (null strings) + "" + (flet ((common-prefix (s1 s2) + (let ((diff-pos (mismatch s1 s2))) + (if diff-pos (subseq s1 0 diff-pos) s1)))) + (reduce #'common-prefix strings)))) + +(defun format-completion-set (strings internal-p package-name) + "Format a set of completion strings. +Returns a list of completions with package qualifiers if needed." + (mapcar (lambda (string) (untokenize-symbol package-name internal-p string)) + (sort strings #'string<))) + + +;;;; Simple arglist display + +(defslimefun operator-arglist (name package) + (ignore-errors + (let ((args (arglist (parse-symbol name (guess-buffer-package package)))) + (*print-escape* nil)) + (cond ((eq args :not-available) nil) + (t (format nil "(~a ~/pprint-fill/)" name args)))))) + + +;;;; Documentation + +(defslimefun apropos-list-for-emacs (name &optional external-only + case-sensitive package) + "Make an apropos search for Emacs. +The result is a list of property lists." + (let ((package (if package + (or (parse-package package) + (error "No such package: ~S" package))))) + ;; The MAPCAN will filter all uninteresting symbols, i.e. those + ;; who cannot be meaningfully described. + (mapcan (listify #'briefly-describe-symbol-for-emacs) + (sort (remove-duplicates + (apropos-symbols name external-only case-sensitive package)) + #'present-symbol-before-p)))) + +(defun briefly-describe-symbol-for-emacs (symbol) + "Return a property list describing SYMBOL. +Like `describe-symbol-for-emacs' but with at most one line per item." + (flet ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos))))) + (let ((desc (map-if #'stringp #'first-line + (describe-symbol-for-emacs symbol)))) + (if desc + (list* :designator (to-string symbol) desc))))) + +(defun map-if (test fn &rest lists) + "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST. +Example: +\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)" + (apply #'mapcar + (lambda (x) (if (funcall test x) (funcall fn x) x)) + lists)) + +(defun listify (f) + "Return a function like F, but which returns any non-null value +wrapped in a list." + (lambda (x) + (let ((y (funcall f x))) + (and y (list y))))) + +(defun present-symbol-before-p (x y) + "Return true if X belongs before Y in a printed summary of symbols. +Sorted alphabetically by package name and then symbol name, except +that symbols accessible in the current package go first." + (declare (type symbol x y)) + (flet ((accessible (s) + ;; Test breaks on NIL for package that does not inherit it + (eq (find-symbol (symbol-name s) *buffer-package*) s))) + (let ((ax (accessible x)) (ay (accessible y))) + (cond ((and ax ay) (string< (symbol-name x) (symbol-name y))) + (ax t) + (ay nil) + (t (let ((px (symbol-package x)) (py (symbol-package y))) + (if (eq px py) + (string< (symbol-name x) (symbol-name y)) + (string< (package-name px) (package-name py))))))))) + +(let ((regex-hash (make-hash-table :test #'equal))) + (defun compiled-regex (regex-string) + (or (gethash regex-string regex-hash) + (setf (gethash regex-string regex-hash) + (if (zerop (length regex-string)) + (lambda (s) (check-type s string) t) + (compile nil (slime-nregex:regex-compile regex-string))))))) + +(defun make-regexp-matcher (string case-sensitive) + (let* ((case-modifier (if case-sensitive #'string #'string-upcase)) + (regex (compiled-regex (funcall case-modifier string)))) + (lambda (symbol) + (funcall regex (funcall case-modifier symbol))))) + +(defun apropos-symbols (string external-only case-sensitive package) + (let ((packages (or package (remove (find-package :keyword) + (list-all-packages)))) + (matcher (make-regexp-matcher string case-sensitive)) + (result)) + (with-package-iterator (next packages :external :internal) + (loop (multiple-value-bind (morep symbol) (next) + (cond ((not morep) (return)) + ((and (if external-only (symbol-external-p symbol) t) + (funcall matcher symbol)) + (push symbol result)))))) + result)) + +(defun call-with-describe-settings (fn) + (let ((*print-readably* nil)) + (funcall fn))) + +(defmacro with-describe-settings ((&rest _) &body body) + (declare (ignore _)) + `(call-with-describe-settings (lambda () ,@body))) + +(defun describe-to-string (object) + (with-describe-settings () + (with-output-to-string (*standard-output*) + (describe object)))) + +(defslimefun describe-symbol (symbol-name) + (with-buffer-syntax () + (describe-to-string (parse-symbol-or-lose symbol-name)))) + +(defslimefun describe-function (name) + (with-buffer-syntax () + (let ((symbol (parse-symbol-or-lose name))) + (describe-to-string (or (macro-function symbol) + (symbol-function symbol)))))) + +(defslimefun describe-definition-for-emacs (name kind) + (with-buffer-syntax () + (with-describe-settings () + (with-output-to-string (*standard-output*) + (describe-definition (parse-symbol-or-lose name) kind))))) + +(defslimefun documentation-symbol (symbol-name &optional default) + (with-buffer-syntax () + (multiple-value-bind (sym foundp) (parse-symbol symbol-name) + (if foundp + (let ((vdoc (documentation sym 'variable)) + (fdoc (documentation sym 'function))) + (or (and (or vdoc fdoc) + (concatenate 'string + fdoc + (and vdoc fdoc '(#\Newline #\Newline)) + vdoc)) + default)) + default)))) + + +;;;; Package Commands + +(defslimefun list-all-package-names (&optional nicknames) + "Return a list of all package names. +Include the nicknames if NICKNAMES is true." + (mapcar #'unparse-name + (if nicknames + (mapcan #'package-names (list-all-packages)) + (mapcar #'package-name (list-all-packages))))) + + +;;;; Tracing + +;; Use eval for the sake of portability... +(defun tracedp (fspec) + (member fspec (eval '(trace)))) + +(defslimefun swank-toggle-trace (spec-string) + (let ((spec (from-string spec-string))) + (cond ((consp spec) ; handle complicated cases in the backend + (toggle-trace spec)) + ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec)) + (format nil "~S is now traced." spec))))) + +(defslimefun untrace-all () + (untrace)) + +(defslimefun redirect-trace-output (target) + (setf (connection.trace-output *emacs-connection*) + (make-output-stream-for-target *emacs-connection* target)) + nil) + + +;;;; Undefing + +(defslimefun undefine-function (fname-string) + (let ((fname (from-string fname-string))) + (format nil "~S" (fmakunbound fname)))) + + +;;;; Profiling + +(defun profiledp (fspec) + (member fspec (profiled-functions))) + +(defslimefun toggle-profile-fdefinition (fname-string) + (let ((fname (from-string fname-string))) + (cond ((profiledp fname) + (unprofile fname) + (format nil "~S is now unprofiled." fname)) + (t + (profile fname) + (format nil "~S is now profiled." fname))))) + + +;;;; Source Locations + +(defslimefun find-definitions-for-emacs (name) + "Return a list ((DSPEC LOCATION) ...) of definitions for NAME. +DSPEC is a string and LOCATION a source location. NAME is a string." + (multiple-value-bind (sexp error) + (ignore-errors (values (from-string name))) + (unless error + (loop for (dspec loc) in (find-definitions sexp) + collect (list (to-string dspec) loc))))) + +(defun alistify (list key test) + "Partition the elements of LIST into an alist. KEY extracts the key +from an element and TEST is used to compare keys." + (declare (type function key)) + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (assoc k alist :test test))) + (if probe + (push e (cdr probe)) + (push (cons k (list e)) alist)))) + alist)) + +(defun location-position< (pos1 pos2) + (cond ((and (position-p pos1) (position-p pos2)) + (< (position-pos pos1) + (position-pos pos2))) + (t nil))) + +(defun partition (list test key) + (declare (type function test key)) + (loop for e in list + if (funcall test (funcall key e)) collect e into yes + else collect e into no + finally (return (values yes no)))) + +(defstruct (xref (:conc-name xref.) + (:type list)) + dspec location) + +(defun location-valid-p (location) + (eq (car location) :location)) + +(defun xref-buffer (xref) + (location-buffer (xref.location xref))) + +(defun xref-position (xref) + (location-buffer (xref.location xref))) + +(defun group-xrefs (xrefs) + "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location. +The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)." + (multiple-value-bind (resolved errors) + (partition xrefs #'location-valid-p #'xref.location) + (let ((alist (alistify resolved #'xref-buffer #'equal))) + (append + (loop for (buffer . list) in alist + collect (cons (second buffer) + (mapcar (lambda (xref) + (cons (to-string (xref.dspec xref)) + (xref.location xref))) + (sort list #'location-position< + :key #'xref-position)))) + (if errors + (list (cons "Unresolved" + (mapcar (lambda (xref) + (cons (to-string (xref.dspec xref)) + (xref.location xref))) + errors)))))))) + +(defslimefun xref (type symbol-name) + (let ((symbol (parse-symbol-or-lose symbol-name *buffer-package*))) + (group-xrefs + (ecase type + (:calls (who-calls symbol)) + (:calls-who (calls-who symbol)) + (:references (who-references symbol)) + (:binds (who-binds symbol)) + (:sets (who-sets symbol)) + (:macroexpands (who-macroexpands symbol)) + (:specializes (who-specializes symbol)) + (:callers (list-callers symbol)) + (:callees (list-callees symbol)))))) + + +;;;; Inspecting + +(defun common-seperated-spec (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast + (loop + for i in list + collect (funcall callback i) + collect ", "))) + +(defun inspector-princ (list) + "Like princ-to-string, but don't rewrite (function foo) as #'foo. +Do NOT pass circular lists to this function." + (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) + (set-pprint-dispatch '(cons (member function)) nil) + (princ-to-string list))) + +(defmethod inspect-for-emacs ((object cons) inspector) + (declare (ignore inspector)) + (if (consp (cdr object)) + (inspect-for-emacs-list object) + (inspect-for-emacs-simple-cons object))) + +(defun inspect-for-emacs-simple-cons (cons) + (values "A cons cell." + (label-value-line* + ('car (car cons)) + ('cdr (cdr cons))))) + +(defun inspect-for-emacs-list (list) + (let ((maxlen 40)) + (multiple-value-bind (length tail) (safe-length list) + (flet ((frob (title list) + (let (lines) + (loop for i from 0 for rest on list do + (if (consp (cdr rest)) ; e.g. (A . (B . ...)) + (push (label-value-line i (car rest)) lines) + (progn ; e.g. (A . NIL) or (A . B) + (push (label-value-line i (car rest) :newline nil) lines) + (when (cdr rest) + (push '((:newline)) lines) + (push (label-value-line ':tail () :newline nil) lines)) + (loop-finish))) + finally + (setf lines (reduce #'append (nreverse lines) :from-end t))) + (values title (append '("Elements:" (:newline)) lines))))) + + (cond ((not length) ; circular + (frob "A circular list." + (cons (car list) + (ldiff (cdr list) list)))) + ((and (<= length maxlen) (not tail)) + (frob "A proper list." list)) + (tail + (frob "An improper list." list)) + (t + (frob "A proper list." list))))))) + +;; (inspect-for-emacs-list '#1=(a #1# . #1# )) + +(defun safe-length (list) + "Similar to `list-length', but avoid errors on improper lists. +Return two values: the length of the list and the last cdr. +NIL is returned if the list is circular." + (do ((n 0 (+ n 2)) ;Counter. + (fast list (cddr fast)) ;Fast pointer: leaps by 2. + (slow list (cdr slow))) ;Slow pointer: leaps by 1. + (nil) + (cond ((null fast) (return (values n nil))) + ((not (consp fast)) (return (values n fast))) + ((null (cdr fast)) (return (values (1+ n) (cdr fast)))) + ((and (eq fast slow) (> n 0)) (return nil)) + ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast))))))) + +(defvar *slime-inspect-contents-limit* nil "How many elements of + a hash table or array to show by default. If table has more than + this then offer actions to view more. Set to nil for no limit." ) + +(defmethod inspect-for-emacs ((ht hash-table) inspector) + (declare (ignore inspector)) + (values (prin1-to-string ht) + (append + (label-value-line* + ("Count" (hash-table-count ht)) + ("Size" (hash-table-size ht)) + ("Test" (hash-table-test ht)) + ("Rehash size" (hash-table-rehash-size ht)) + ("Rehash threshold" (hash-table-rehash-threshold ht))) + (let ((weakness (hash-table-weakness ht))) + (when weakness + `("Weakness: " (:value ,weakness) (:newline)))) + (unless (zerop (hash-table-count ht)) + `((:action "[clear hashtable]" ,(lambda () (clrhash ht))) (:newline) + "Contents: " (:newline))) + (if (and *slime-inspect-contents-limit* + (>= (hash-table-count ht) *slime-inspect-contents-limit*)) + (inspect-bigger-piece-actions ht (hash-table-count ht)) + nil) + (loop for key being the hash-keys of ht + for value being the hash-values of ht + repeat (or *slime-inspect-contents-limit* most-positive-fixnum) + append `((:value ,key) " = " (:value ,value) + " " (:action "[remove entry]" + ,(let ((key key)) + (lambda () (remhash key ht)))) + (:newline)))))) + +(defun inspect-bigger-piece-actions (thing size) + (append + (if (> size *slime-inspect-contents-limit*) + (list (inspect-show-more-action thing) + '(:newline)) + nil) + (list (inspect-whole-thing-action thing size) + '(:newline)))) + +(defun inspect-whole-thing-action (thing size) + `(:action ,(format nil "Inspect all ~a elements." + size) + ,(lambda() + (let ((*slime-inspect-contents-limit* nil)) + (swank::inspect-object thing))))) + +(defun inspect-show-more-action (thing) + `(:action ,(format nil "~a elements shown. Prompt for how many to inspect..." + *slime-inspect-contents-limit* ) + ,(lambda() + (let ((*slime-inspect-contents-limit* + (progn (format t "How many elements should be shown? ") (read)))) + (swank::inspect-object thing))))) + +(defmethod inspect-for-emacs ((array array) inspector) + (declare (ignore inspector)) + (values "An array." + (append + (label-value-line* + ("Dimensions" (array-dimensions array)) + ("Its element type is" (array-element-type array)) + ("Total size" (array-total-size array)) + ("Adjustable" (adjustable-array-p array))) + (when (array-has-fill-pointer-p array) + (label-value-line "Fill pointer" (fill-pointer array))) + '("Contents:" (:newline)) + (if (and *slime-inspect-contents-limit* + (>= (array-total-size array) *slime-inspect-contents-limit*)) + (inspect-bigger-piece-actions array (length array)) + nil) + (loop for i below (or *slime-inspect-contents-limit* (array-total-size array)) + append (label-value-line i (row-major-aref array i)))))) + +(defmethod inspect-for-emacs ((char character) inspector) + (declare (ignore inspector)) + (values "A character." + (append + (label-value-line* + ("Char code" (char-code char)) + ("Lower cased" (char-downcase char)) + ("Upper cased" (char-upcase char))) + (if (get-macro-character char) + `("In the current readtable (" + (:value ,*readtable*) ") it is a macro character: " + (:value ,(get-macro-character char))))))) + +(defvar *inspectee*) +(defvar *inspectee-parts*) +(defvar *inspectee-actions*) +(defvar *inspector-stack* '()) +(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)) +(declaim (type vector *inspector-history*)) +(defvar *inspect-length* 30) +(defvar *default-inspector* (make-default-inspector)) + +(defun reset-inspector () + (setq *inspectee* nil + *inspector-stack* nil + *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0) + *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0) + *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) + +;; FIXME: Unused? +(defun valid-function-name-p (form) + (or (and (not (null form)) + (not (eq form t)) + (symbolp form)) + (and (consp form) + (second form) + (not (third form)) + (eq (first form) 'setf)))) + +(defslimefun init-inspector (string) + (with-buffer-syntax () + (reset-inspector) + (inspect-object (eval (read-from-string string))))) + +(defun print-part-to-string (value) + (let ((string (to-string value)) + (pos (position value *inspector-history*))) + (if pos + (format nil "#~D=~A" pos string) + string))) + +(defun inspector-content-for-emacs (specs) + (loop for part in specs collect + (etypecase part + (null ; XXX encourages sloppy programming + nil) + (string part) + (cons (destructure-case part + ((:newline) + (string #\newline)) + ((:value obj &optional str) + (value-part-for-emacs obj str)) + ((:action label lambda &key (refreshp t)) + (action-part-for-emacs label lambda refreshp))))))) + +(defun assign-index (object vector) + (let ((index (fill-pointer vector))) + (vector-push-extend object vector) + index)) + +(defun value-part-for-emacs (object string) + (list :value + (or string (print-part-to-string object)) + (assign-index object *inspectee-parts*))) + +(defun action-part-for-emacs (label lambda refreshp) + (list :action label (assign-index (list lambda refreshp) + *inspectee-actions*))) + +(defun inspect-object (object &optional (inspector *default-inspector*)) + (push (setq *inspectee* object) *inspector-stack*) + (unless (find object *inspector-history*) + (vector-push-extend object *inspector-history*)) + (let ((*print-pretty* nil) ; print everything in the same line + (*print-circle* t) + (*print-readably* nil)) + (multiple-value-bind (title content) (inspect-for-emacs object inspector) + (list :title title + :type (to-string (type-of object)) + :content (inspector-content-for-emacs content))))) + +(defslimefun inspector-nth-part (index) + (aref *inspectee-parts* index)) + +(defslimefun inspect-nth-part (index) + (with-buffer-syntax () + (inspect-object (inspector-nth-part index)))) + +(defslimefun inspector-call-nth-action (index &rest args) + (destructuring-bind (action-lambda refreshp) + (aref *inspectee-actions* index) + (apply action-lambda args) + (if refreshp + (inspect-object (pop *inspector-stack*)) + ;; tell emacs that we don't want to refresh the inspector buffer + nil))) + +(defslimefun inspector-pop () + "Drop the inspector stack and inspect the second element. Return +nil if there's no second element." + (with-buffer-syntax () + (cond ((cdr *inspector-stack*) + (pop *inspector-stack*) + (inspect-object (pop *inspector-stack*))) + (t nil)))) + +(defslimefun inspector-next () + "Inspect the next element in the *inspector-history*." + (with-buffer-syntax () + (let ((position (position *inspectee* *inspector-history*))) + (cond ((= (1+ position) (length *inspector-history*)) + nil) + (t (inspect-object (aref *inspector-history* (1+ position)))))))) + +(defslimefun inspector-reinspect () + (inspect-object *inspectee*)) + +(defslimefun quit-inspector () + (reset-inspector) + nil) + +(defslimefun describe-inspectee () + "Describe the currently inspected object." + (with-buffer-syntax () + (describe-to-string *inspectee*))) + +(defslimefun pprint-inspector-part (index) + "Pretty-print the currently inspected object." + (with-buffer-syntax () + (swank-pprint (list (inspector-nth-part index))))) + +(defslimefun inspect-in-frame (string index) + (with-buffer-syntax () + (reset-inspector) + (inspect-object (eval-in-frame (from-string string) index)))) + +(defslimefun inspect-current-condition () + (with-buffer-syntax () + (reset-inspector) + (inspect-object *swank-debugger-condition*))) + +(defslimefun inspect-frame-var (frame var) + (with-buffer-syntax () + (reset-inspector) + (inspect-object (frame-var-value frame var)))) + + +;;;; Thread listing + +(defvar *thread-list* () + "List of threads displayed in Emacs. We don't care a about +synchronization issues (yet). There can only be one thread listing at +a time.") + +(defslimefun list-threads () + "Return a list ((NAME DESCRIPTION) ...) of all threads." + (setq *thread-list* (all-threads)) + (loop for thread in *thread-list* + for name = (thread-name thread) + collect (list (if (symbolp name) (symbol-name name) name) + (thread-status thread) + (thread-id thread)))) + +(defslimefun quit-thread-browser () + (setq *thread-list* nil)) + +(defun nth-thread (index) + (nth index *thread-list*)) + +(defslimefun debug-nth-thread (index) + (let ((connection *emacs-connection*)) + (interrupt-thread (nth-thread index) + (lambda () + (with-connection (connection) + (simple-break)))))) + +(defslimefun kill-nth-thread (index) + (kill-thread (nth-thread index))) + +(defslimefun start-swank-server-in-thread (index port-file-name) + "Interrupt the INDEXth thread and make it start a swank server. +The server port is written to PORT-FILE-NAME." + (interrupt-thread (nth-thread index) + (lambda () + (start-server port-file-name :style nil)))) + +;;;; Class browser + +(defun mop-helper (class-name fn) + (let ((class (find-class class-name nil))) + (if class + (mapcar (lambda (x) (to-string (class-name x))) + (funcall fn class))))) + +(defslimefun mop (type symbol-name) + "Return info about classes using mop. + + When type is: + :subclasses - return the list of subclasses of class. + :superclasses - return the list of superclasses of class." + (let ((symbol (parse-symbol symbol-name *buffer-package*))) + (ecase type + (:subclasses + (mop-helper symbol #'swank-mop:class-direct-subclasses)) + (:superclasses + (mop-helper symbol #'swank-mop:class-direct-superclasses))))) + + +;;;; Automatically synchronized state +;;; +;;; Here we add hooks to push updates of relevant information to +;;; Emacs. + +;;;;; *FEATURES* + +(defun sync-features-to-emacs () + "Update Emacs if any relevant Lisp state has changed." + ;; FIXME: *slime-features* should be connection-local + (unless (eq *slime-features* *features*) + (setq *slime-features* *features*) + (send-to-emacs (list :new-features (features-for-emacs))))) + +(defun features-for-emacs () + "Return `*slime-features*' in a format suitable to send it to Emacs." + *slime-features*) + +(add-hook *pre-reply-hook* 'sync-features-to-emacs) + + +;;;;; Indentation of macros +;;; +;;; This code decides how macros should be indented (based on their +;;; arglists) and tells Emacs. A per-connection cache is used to avoid +;;; sending redundant information to Emacs -- we just say what's +;;; changed since last time. +;;; +;;; The strategy is to scan all symbols, pick out the macros, and look +;;; for &body-arguments. + +(defvar *configure-emacs-indentation* t + "When true, automatically send indentation information to Emacs +after each command.") + +(defslimefun update-indentation-information () + (perform-indentation-update *emacs-connection* t) + nil) + +;; This function is for *PRE-REPLY-HOOK*. +(defun sync-indentation-to-emacs () + "Send any indentation updates to Emacs via CONNECTION." + (when *configure-emacs-indentation* + (let ((fullp (need-full-indentation-update-p *emacs-connection*))) + (perform-indentation-update *emacs-connection* fullp)))) + +(defun need-full-indentation-update-p (connection) + "Return true if the whole indentation cache should be updated. +This is a heuristic to avoid scanning all symbols all the time: +instead, we only do a full scan if the set of packages has changed." + (set-difference (list-all-packages) + (connection.indentation-cache-packages connection))) + +(defun perform-indentation-update (connection force) + "Update the indentation cache in CONNECTION and update Emacs. +If FORCE is true then start again without considering the old cache." + (let ((cache (connection.indentation-cache connection))) + (when force (clrhash cache)) + (let ((delta (update-indentation/delta-for-emacs cache force))) + (setf (connection.indentation-cache-packages connection) + (list-all-packages)) + (unless (null delta) + (send-to-emacs (list :indentation-update delta)))))) + +(defun update-indentation/delta-for-emacs (cache &optional force) + "Update the cache and return the changes in a (SYMBOL . INDENT) list. +If FORCE is true then check all symbols, otherwise only check symbols +belonging to the buffer package." + (let ((alist '())) + (flet ((consider (symbol) + (let ((indent (symbol-indentation symbol))) + (when indent + (unless (equal (gethash symbol cache) indent) + (setf (gethash symbol cache) indent) + (push (cons (string-downcase symbol) indent) alist)))))) + (if force + (do-all-symbols (symbol) + (consider symbol)) + (do-symbols (symbol *buffer-package*) + ;; We're really just interested in the symbols of *BUFFER-PACKAGE*, + ;; and *not* all symbols that are _present_ (cf. SYMBOL-STATUS.) + (when (eq (symbol-package symbol) *buffer-package*) + (consider symbol))))) + alist)) + +(defun package-names (package) + "Return the name and all nicknames of PACKAGE in a fresh list." + (cons (package-name package) (copy-list (package-nicknames package)))) + +(defun cl-symbol-p (symbol) + "Is SYMBOL a symbol in the COMMON-LISP package?" + (eq (symbol-package symbol) cl-package)) + +(defun known-to-emacs-p (symbol) + "Return true if Emacs has special rules for indenting SYMBOL." + (cl-symbol-p symbol)) + +(defun symbol-indentation (symbol) + "Return a form describing the indentation of SYMBOL. +The form is to be used as the `common-lisp-indent-function' property +in Emacs." + (if (and (macro-function symbol) + (not (known-to-emacs-p symbol))) + (let ((arglist (arglist symbol))) + (etypecase arglist + ((member :not-available) + nil) + (list + (macro-indentation arglist)))) + nil)) + +(defun macro-indentation (arglist) + (if (well-formed-list-p arglist) + (position '&body (remove '&optional (clean-arglist arglist))) + nil)) + +(defun clean-arglist (arglist) + "Remove &whole, &enviroment, and &aux elements from ARGLIST." + (cond ((null arglist) '()) + ((member (car arglist) '(&whole &environment)) + (clean-arglist (cddr arglist))) + ((eq (car arglist) '&aux) + '()) + (t (cons (car arglist) (clean-arglist (cdr arglist)))))) + +(defun well-formed-list-p (list) + "Is LIST a proper list terminated by NIL?" + (typecase list + (null t) + (cons (well-formed-list-p (cdr list))) + (t nil))) + +(defun print-indentation-lossage (&optional (stream *standard-output*)) + "Return the list of symbols whose indentation styles collide incompatibly. +Collisions are caused because package information is ignored." + (let ((table (make-hash-table :test 'equal))) + (flet ((name (s) (string-downcase (symbol-name s)))) + (do-all-symbols (s) + (setf (gethash (name s) table) + (cons s (symbol-indentation s)))) + (let ((collisions '())) + (do-all-symbols (s) + (let* ((entry (gethash (name s) table)) + (owner (car entry)) + (indent (cdr entry))) + (unless (or (eq s owner) + (equal (symbol-indentation s) indent) + (and (not (fboundp s)) + (null (macro-function s)))) + (pushnew owner collisions) + (pushnew s collisions)))) + (if (null collisions) + (format stream "~&No worries!~%") + (format stream "~&Symbols with collisions:~%~{ ~S~%~}" + collisions)))))) + +(add-hook *pre-reply-hook* 'sync-indentation-to-emacs) + +;;; swank.lisp ends here Added: branches/trunk-reorg/thirdparty/slime/test-all.sh =================================================================== --- branches/trunk-reorg/thirdparty/slime/test-all.sh 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/test-all.sh 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,14 @@ +#!/bin/sh + +# This code has been placed in the Public Domain. All warranties +# are disclaimed. + +trap EXIT + +for emacs in xemacs ; do # emacs-20.7 emacs-21.3.50 xemacs ; do + for lisp in 'cmucl -noinit' sbcl lispworks-personal-4300 'clisp -K full' acl5; do + echo testing: $emacs $lisp dribble.$emacs_$lisp result.$emacs_$lisp + test.sh $emacs "$lisp" "dribble.${emacs}_${lisp}" "result.${emacs}_${lisp}" + done +done + \ No newline at end of file Property changes on: branches/trunk-reorg/thirdparty/slime/test-all.sh ___________________________________________________________________ Name: svn:executable + * Added: branches/trunk-reorg/thirdparty/slime/test.sh =================================================================== --- branches/trunk-reorg/thirdparty/slime/test.sh 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/test.sh 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,82 @@ +#!/bin/sh + +# Run the SLIME test suite inside screen, saving the results to a file. + +# This script's exit status is the number of tests failed. If no tests +# fail then no output is printed. If at least one test fails then a +# one-line summary is printed. + +# If something unexpected fails, you might get an exit code like 127 +# or 255 instead. Sorry. + +# This code has been placed in the Public Domain. All warranties +# are disclaimed. + +function usage () { + echo "Usage: $name [-v] [-r] <emacs> <lisp>" + exit 1 +} + +name=$0 + +while getopts vr opt; do + case $opt in + v) verbose=true;; + r) dump_results=true;; + *) usage;; + esac +done + +shift $((OPTIND - 1)) +[ $# = 2 ] || usage + +emacs=$1; lisp=$2; + +# Move the code into a directory in /tmp, so that we can compile it +# for the current lisp. + +slimedir=$(dirname $name) +testdir=/tmp/slime-test.$$ +results=$testdir/results +dribble=$testdir/dribble +statusfile=$testdir/status + +test -d $testdir && rm -r $testdir + +trap "rm -r $testdir" EXIT # remove temporary directory on exit + +mkdir $testdir +cp -r $slimedir/*.{el,lisp} ChangeLog $slimedir/contrib $testdir +mkfifo $dribble + +session=slime-screen.$$ + +screen -S $session -m -D bash -c "$emacs -nw -q -no-site-file --no-site-file \ + --eval '(setq debug-on-quit t)' \ + --eval '(setq max-lisp-eval-depth 1000)' \ + --eval '(setq load-path (cons \"$testdir\" load-path))' \ + --eval '(require (quote slime))' \ + --eval '(setq inferior-lisp-program \"$lisp\")' \ + --eval '(slime-batch-test \"$results\")' > $dribble;\ + echo \$? > $statusfile" & + +screenpid=$! + +if [ "$verbose" = true ]; then + cat $dribble & +else + cat $dribble > /dev/null & +fi; + +trap "screen -S $session -X quit" SIGINT +wait $screenpid + +if [ -f "$statusfile" ]; then + [ "$dump_results" = true ] && cat $results; + echo $(cat $statusfile) "test(s) failed." +else + # Tests crashed + echo crashed +fi + +exit $status Property changes on: branches/trunk-reorg/thirdparty/slime/test.sh ___________________________________________________________________ Name: svn:executable + * Added: branches/trunk-reorg/thirdparty/slime/xref.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/xref.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/xref.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,2891 @@ +;;; -*- Mode: LISP; Package: XREF; Syntax: Common-lisp; -*- +;;; Mon Jan 21 16:21:20 1991 by Mark Kantrowitz <mkant(a)GLINDA.OZ.CS.CMU.EDU> +;;; xref.lisp + +;;; **************************************************************** +;;; List Callers: A Static Analysis Cross Referencing Tool for Lisp +;;; **************************************************************** +;;; +;;; The List Callers system is a portable Common Lisp cross referencing +;;; utility. It grovels over a set of files and compiles a database of the +;;; locations of all references for each symbol used in the files. +;;; List Callers is similar to the Symbolics Who-Calls and the +;;; Xerox Masterscope facilities. +;;; +;;; When you change a function or variable definition, it can be useful +;;; to know its callers, in order to update each of them to the new +;;; definition. Similarly, having a graphic display of the structure +;;; (e.g., call graph) of a program can help make undocumented code more +;;; understandable. This static code analyzer facilitates both capabilities. +;;; The database compiled by xref is suitable for viewing by a graphical +;;; browser. (Note: the reference graph is not necessarily a DAG. Since many +;;; graphical browsers assume a DAG, this will lead to infinite loops. +;;; Some code which is useful in working around this problem is included, +;;; as well as a sample text-indenting outliner and an interface to Bates' +;;; PSGraph Postscript Graphing facility.) +;;; +;;; Written by Mark Kantrowitz, July 1990. +;;; +;;; Address: School of Computer Science +;;; Carnegie Mellon University +;;; Pittsburgh, PA 15213 +;;; +;;; Copyright (c) 1990. All rights reserved. +;;; +;;; See general license below. +;;; + +;;; **************************************************************** +;;; General License Agreement and Lack of Warranty ***************** +;;; **************************************************************** +;;; +;;; This software is distributed in the hope that it will be useful (both +;;; in and of itself and as an example of lisp programming), but WITHOUT +;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for +;;; the consequences of using it or for whether it serves any particular +;;; purpose or works at all. No warranty is made about the software or its +;;; performance. +;;; +;;; Use and copying of this software and the preparation of derivative +;;; works based on this software are permitted, so long as the following +;;; conditions are met: +;;; o The copyright notice and this entire notice are included intact +;;; and prominently carried on all copies and supporting documentation. +;;; o No fees or compensation are charged for use, copies, or +;;; access to this software. You may charge a nominal +;;; distribution fee for the physical act of transferring a +;;; copy, but you may not charge for the program itself. +;;; o If you modify this software, you must cause the modified +;;; file(s) to carry prominent notices (a Change Log) +;;; describing the changes, who made the changes, and the date +;;; of those changes. +;;; o Any work distributed or published that in whole or in part +;;; contains or is a derivative of this software or any part +;;; thereof is subject to the terms of this agreement. The +;;; aggregation of another unrelated program with this software +;;; or its derivative on a volume of storage or distribution +;;; medium does not bring the other program under the scope +;;; of these terms. +;;; o Permission is granted to manufacturers and distributors of +;;; lisp compilers and interpreters to include this software +;;; with their distribution. +;;; +;;; This software is made available AS IS, and is distributed without +;;; warranty of any kind, either expressed or implied. +;;; +;;; In no event will the author(s) or their institutions be liable to you +;;; for damages, including lost profits, lost monies, or other special, +;;; incidental or consequential damages arising out of or in connection +;;; with the use or inability to use (including but not limited to loss of +;;; data or data being rendered inaccurate or losses sustained by third +;;; parties or a failure of the program to operate as documented) the +;;; program, even if you have been advised of the possibility of such +;;; damanges, or for any claim by any other party, whether in an action of +;;; contract, negligence, or other tortious action. +;;; +;;; The current version of this software and a variety of related utilities +;;; may be obtained by anonymous ftp from ftp.cs.cmu.edu in the directory +;;; user/ai/lang/lisp/code/tools/xref/ +;;; +;;; Please send bug reports, comments, questions and suggestions to +;;; mkant(a)cs.cmu.edu. We would also appreciate receiving any changes +;;; or improvements you may make. +;;; +;;; If you wish to be added to the Lisp-Utilities(a)cs.cmu.edu mailing list, +;;; send email to Lisp-Utilities-Request(a)cs.cmu.edu with your name, email +;;; address, and affiliation. This mailing list is primarily for +;;; notification about major updates, bug fixes, and additions to the lisp +;;; utilities collection. The mailing list is intended to have low traffic. +;;; + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; 27-FEB-91 mk Added insert arg to psgraph-xref to allow the postscript +;;; graphs to be inserted in Scribe documents. +;;; 21-FEB-91 mk Added warning if not compiled. +;;; 07-FEB-91 mk Fixed bug in record-callers with regard to forms at +;;; toplevel. +;;; 21-JAN-91 mk Added file xref-test.lisp to test xref. +;;; 16-JAN-91 mk Added definition WHO-CALLS to parallel the Symbolics syntax. +;;; 16-JAN-91 mk Added macroexpansion capability to record-callers. Also +;;; added parameter *handle-macro-forms*, defaulting to T. +;;; 16-JAN-91 mk Modified print-caller-tree and related functions +;;; to allow the user to specify root nodes. If the user +;;; doesn't specify them, it will default to all root +;;; nodes, as before. +;;; 16-JAN-91 mk Added parameter *default-graphing-mode* to specify +;;; the direction of the graphing. Either :call-graph, +;;; where the children of a node are those functions called +;;; by the node, or :caller-graph where the children of a +;;; node are the callers of the node. :call-graph is the +;;; default. +;;; 16-JAN-91 mk Added parameter *indent-amount* to control the indentation +;;; in print-indented-tree. +;;; 16-JUL-90 mk Functions with argument lists of () were being ignored +;;; because of a (when form) wrapped around the body of +;;; record-callers. Then intent of (when form) was as an extra +;;; safeguard against infinite looping. This wasn't really +;;; necessary, so it has been removed. +;;; 16-JUL-90 mk PSGraph-XREF now has keyword arguments, instead of +;;; optionals. +;;; 16-JUL-90 mk Added PRINT-CLASS-HIERARCHY to use psgraph to graph the +;;; CLOS class hierarchy. This really doesn't belong here, +;;; and should be moved to psgraph.lisp as an example of how +;;; to use psgraph. +;;; 16-JUL-90 mk Fixed several caller patterns. The pattern for member +;;; had an error which caused many references to be missed. +;;; 16-JUL-90 mk Added ability to save/load processed databases. +;;; 5-JUL-91 mk Fixed warning of needing compilation to occur only when the +;;; source is loaded. +;;; 20-SEP-93 mk Added fix from Peter Norvig to allow Xref to xref itself. +;;; The arg to macro-function must be a symbol. + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; Verify that: +;;; o null forms don't cause it to infinite loop. +;;; o nil matches against null argument lists. +;;; o declarations and doc are being ignored. +;;; +;;; Would be nice if in addition to showing callers of a function, it +;;; displayed the context of the calls to the function (e.g., the +;;; immediately surrounding form). This entails storing entries of +;;; the form (symbol context*) in the database and augmenting +;;; record-callers to keep the context around. The only drawbacks is +;;; that it would cons a fair bit. If we do this, we should store +;;; additional information as well in the database, such as the caller +;;; pattern type (e.g., variable vs. function). +;;; +;;; Write a translator from BNF (at least as much of BNF as is used +;;; in CLtL2), to the format used here. +;;; +;;; Should automatically add new patterns for new functions and macros +;;; based on their arglists. Probably requires much more than this +;;; simple code walker, so there isn't much we can do. +;;; +;;; Defmacro is a problem, because it often hides internal function +;;; calls within backquote and quote, which we normally ignore. If +;;; we redefine QUOTE's pattern so that it treats the arg like a FORM, +;;; we'll probably get them (though maybe the syntax will be mangled), +;;; but most likely a lot of spurious things as well. +;;; +;;; Define an operation for Defsystem which will run XREF-FILE on the +;;; files of the system. Or yet simpler, when XREF sees a LOAD form +;;; for which the argument is a string, tries to recursively call +;;; XREF-FILE on the specified file. Then one could just XREF-FILE +;;; the file which loads the system. (This should be a program +;;; parameter.) +;;; +;;; Have special keywords which the user may place in a file to have +;;; XREF-FILE ignore a region. +;;; +;;; Should we distinguish flet and labels from defun? I.e., note that +;;; flet's definitions are locally defined, instead of just lumping +;;; them in with regular definitions. +;;; +;;; Add patterns for series, loop macro. +;;; +;;; Need to integrate the variable reference database with the other +;;; databases, yet maintain separation. So we can distinguish all +;;; the different types of variable and function references, without +;;; multiplying databases. +;;; +;;; Would pay to comment record-callers and record-callers* in more +;;; depth. +;;; +;;; (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT) + +;;; ******************************** +;;; Notes ************************** +;;; ******************************** +;;; +;;; XREF has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; Macintosh Allegro Common Lisp (1.3.2) +;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90) +;;; Lucid CL (Version 2.1 6-DEC-87) +;;; +;;; XREF has been tested (unsuccessfully) in the following lisps: +;;; Ibuki Common Lisp (01/01, October 15, 1987) +;;; - if interpreted, runs into stack overflow +;;; - does not compile (tried ibcl on Suns, PMAXes and RTs) +;;; seems to be due to a limitation in the c compiler. +;;; +;;; XREF needs to be tested in the following lisps: +;;; Symbolics Common Lisp (8.0) +;;; Lucid Common Lisp (3.0, 4.0) +;;; KCL (June 3, 1987 or later) +;;; AKCL (1.86, June 30, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; VAXLisp (2.0, 3.1) +;;; HP Common Lisp (same as Lucid?) +;;; Procyon Common Lisp + + +;;; **************************************************************** +;;; Documentation ************************************************** +;;; **************************************************************** +;;; +;;; XREF analyzes a user's program, determining which functions call a +;;; given function, and the location of where variables are bound/assigned +;;; and used. The user may retrieve this information for either a single +;;; symbol, or display the call graph of portions of the program +;;; (including the entire program). This allows the programmer to debug +;;; and document the program's structure. +;;; +;;; XREF is primarily intended for analyzing large programs, where it is +;;; difficult, if not impossible, for the programmer to grasp the structure +;;; of the whole program. Nothing precludes using XREF for smaller programs, +;;; where it can be useful for inspecting the relationships between pieces +;;; of the program and for documenting the program. +;;; +;;; Two aspects of the Lisp programming language greatly simplify the +;;; analysis of Lisp programs: +;;; o Lisp programs are naturally represented as data. +;;; Successive definitions from a file are easily read in +;;; as list structure. +;;; o The basic syntax of Lisp is uniform. A list program +;;; consists of a set of nested forms, where each form is +;;; a list whose car is a tag (e.g., function name) that +;;; specifies the structure of the rest of the form. +;;; Thus Lisp programs, when represented as data, can be considered to be +;;; parse trees. Given a grammar of syntax patterns for the language, XREF +;;; recursively descends the parse tree for a given definition, computing +;;; a set of relations that hold for the definition at each node in the +;;; tree. For example, one kind of relation is that the function defined +;;; by the definition calls the functions in its body. The relations are +;;; stored in a database for later examination by the user. +;;; +;;; While XREF currently only works for programs written in Lisp, it could +;;; be extended to other programming languages by writing a function to +;;; generate parse trees for definitions in that language, and a core +;;; set of patterns for the language's syntax. +;;; +;;; Since XREF normally does a static syntactic analysis of the program, +;;; it does not detect references due to the expansion of a macro definition. +;;; To do this in full generality XREF would have to have knowledge about the +;;; semantics of the program (e.g., macros which call other functions to +;;; do the expansion). This entails either modifying the compiler to +;;; record the relationships (e.g., Symbolics Who-Calls Database) or doing +;;; a walk of loaded code and macroexpanding as needed (PCL code walker). +;;; The former is not portable, while the latter requires that the code +;;; used by macros be loaded and in working order. On the other hand, then +;;; we would need no special knowledge about macros (excluding the 24 special +;;; forms of Lisp). +;;; +;;; Parameters may be set to enable macro expansion in XREF. Then XREF +;;; will expand any macros for which it does not have predefined patterns. +;;; (For example, most Lisps will implement dolist as a macro. Since XREF +;;; has a pattern defined for dolist, it will not call macroexpand-1 on +;;; a form whose car is dolist.) For this to work properly, the code must +;;; be loaded before being processed by XREF, and XREF's parameters should +;;; be set so that it processes forms in their proper packages. +;;; +;;; If macro expansion is disabled, the default rules for handling macro +;;; references may not be sufficient for some user-defined macros, because +;;; macros allow a variety of non-standard syntactic extensions to the +;;; language. In this case, the user may specify additional templates in +;;; a manner similar to that in which the core Lisp grammar was specified. +;;; + + +;;; ******************************** +;;; User Guide ********************* +;;; ******************************** +;;; ----- +;;; The following functions are called to cross reference the source files. +;;; +;;; XREF-FILES (&rest files) [FUNCTION] +;;; Grovels over the lisp code located in source file FILES, using +;;; xref-file. +;;; +;;; XREF-FILE (filename &optional clear-tables verbose) [Function] +;;; Cross references the function and variable calls in FILENAME by +;;; walking over the source code located in the file. Defaults type of +;;; filename to ".lisp". Chomps on the code using record-callers and +;;; record-callers*. If CLEAR-TABLES is T (the default), it clears the +;;; callers database before processing the file. Specify CLEAR-TABLES as +;;; nil to append to the database. If VERBOSE is T (the default), prints +;;; out the name of the file, one progress dot for each form processed, +;;; and the total number of forms. +;;; +;;; ----- +;;; The following functions display information about the uses of the +;;; specified symbol as a function, variable, or constant. +;;; +;;; LIST-CALLERS (symbol) [FUNCTION] +;;; Lists all functions which call SYMBOL as a function (function +;;; invocation). +;;; +;;; LIST-READERS (symbol) [FUNCTION] +;;; Lists all functions which refer to SYMBOL as a variable +;;; (variable reference). +;;; +;;; LIST-SETTERS (symbol) [FUNCTION] +;;; Lists all functions which bind/set SYMBOL as a variable +;;; (variable mutation). +;;; +;;; LIST-USERS (symbol) [FUNCTION] +;;; Lists all functions which use SYMBOL as a variable or function. +;;; +;;; WHO-CALLS (symbol &optional how) [FUNCTION] +;;; Lists callers of symbol. HOW may be :function, :reader, :setter, +;;; or :variable." +;;; +;;; WHAT-FILES-CALL (symbol) [FUNCTION] +;;; Lists names of files that contain uses of SYMBOL +;;; as a function, variable, or constant. +;;; +;;; SOURCE-FILE (symbol) [FUNCTION] +;;; Lists the names of files in which SYMBOL is defined/used. +;;; +;;; LIST-CALLEES (symbol) [FUNCTION] +;;; Lists names of functions and variables called by SYMBOL. +;;; +;;; ----- +;;; The following functions may be useful for viewing the database and +;;; debugging the calling patterns. +;;; +;;; *LAST-FORM* () [VARIABLE] +;;; The last form read from the file. Useful for figuring out what went +;;; wrong when xref-file drops into the debugger. +;;; +;;; *XREF-VERBOSE* t [VARIABLE] +;;; When T, xref-file(s) prints out the names of the files it looks at, +;;; progress dots, and the number of forms read. +;;; +;;; *TYPES-TO-IGNORE* (quote (:lisp :lisp2)) [VARIABLE] +;;; Default set of caller types (as specified in the patterns) to ignore +;;; in the database handling functions. :lisp is CLtL 1st edition, +;;; :lisp2 is additional patterns from CLtL 2nd edition. +;;; +;;; *HANDLE-PACKAGE-FORMS* () [VARIABLE] +;;; When non-NIL, and XREF-FILE sees a package-setting form like +;;; IN-PACKAGE, sets the current package to the specified package by +;;; evaluating the form. When done with the file, xref-file resets the +;;; package to its original value. In some of the displaying functions, +;;; when this variable is non-NIL one may specify that all symbols from a +;;; particular set of packages be ignored. This is only useful if the +;;; files use different packages with conflicting names. +;;; +;;; *HANDLE-FUNCTION-FORMS* t [VARIABLE] +;;; When T, XREF-FILE tries to be smart about forms which occur in +;;; a function position, such as lambdas and arbitrary Lisp forms. +;;; If so, it recursively calls record-callers with pattern 'FORM. +;;; If the form is a lambda, makes the caller a caller of +;;; :unnamed-lambda. +;;; +;;; *HANDLE-MACRO-FORMS* t [VARIABLE] +;;; When T, if the file was loaded before being processed by XREF, and +;;; the car of a form is a macro, it notes that the parent calls the +;;; macro, and then calls macroexpand-1 on the form. +;;; +;;; *DEFAULT-GRAPHING-MODE* :call-graph [VARIABLE] +;;; Specifies whether we graph up or down. If :call-graph, the children +;;; of a node are the functions it calls. If :caller-graph, the +;;; children of a node are the functions that call it. +;;; +;;; *INDENT-AMOUNT* 3 [VARIABLE] +;;; Number of spaces to indent successive levels in PRINT-INDENTED-TREE. +;;; +;;; DISPLAY-DATABASE (&optional database types-to-ignore) [FUNCTION] +;;; Prints out the name of each symbol and all its callers. Specify +;;; database :callers (the default) to get function call references, +;;; :file to the get files in which the symbol is called, :readers to get +;;; variable references, and :setters to get variable binding and +;;; assignments. Ignores functions of types listed in types-to-ignore. +;;; +;;; PRINT-CALLER-TREES (&key (mode *default-graphing-mode*) [FUNCTION] +;;; (types-to-ignore *types-to-ignore*) +;;; compact root-nodes) +;;; Prints the calling trees (which may actually be a full graph and not +;;; necessarily a DAG) as indented text trees using +;;; PRINT-INDENTED-TREE. MODE is :call-graph for trees where the children +;;; of a node are the functions called by the node, or :caller-graph for +;;; trees where the children of a node are the functions the node calls. +;;; TYPES-TO-IGNORE is a list of funcall types (as specified in the +;;; patterns) to ignore in printing out the database. For example, +;;; '(:lisp) would ignore all calls to common lisp functions. COMPACT is +;;; a flag to tell the program to try to compact the trees a bit by not +;;; printing trees if they have already been seen. ROOT-NODES is a list +;;; of root nodes of trees to display. If ROOT-NODES is nil, tries to +;;; find all root nodes in the database. +;;; +;;; MAKE-CALLER-TREE (&optional (mode *default-graphing-mode*) [FUNCTION] +;;; (types-to-ignore *types-to-ignore*) +;;; compact) +;;; Outputs list structure of a tree which roughly represents the +;;; possibly cyclical structure of the caller database. +;;; If mode is :call-graph, the children of a node are the functions +;;; it calls. If mode is :caller-graph, the children of a node are the +;;; functions that call it. +;;; If compact is T, tries to eliminate the already-seen nodes, so +;;; that the graph for a node is printed at most once. Otherwise it will +;;; duplicate the node's tree (except for cycles). This is usefull +;;; because the call tree is actually a directed graph, so we can either +;;; duplicate references or display only the first one. +;;; +;;; DETERMINE-FILE-DEPENDENCIES (&optional database) [FUNCTION] +;;; Makes a hash table of file dependencies for the references listed in +;;; DATABASE. This function may be useful for automatically resolving +;;; file references for automatic creation of a system definition +;;; (defsystem). +;;; +;;; PRINT-FILE-DEPENDENCIES (&optional database) [FUNCTION] +;;; Prints a list of file dependencies for the references listed in +;;; DATABASE. This function may be useful for automatically computing +;;; file loading constraints for a system definition tool. +;;; +;;; WRITE-CALLERS-DATABASE-TO-FILE (filename) [FUNCTION] +;;; Saves the contents of the current callers database to a file. This +;;; file can be loaded to restore the previous contents of the +;;; database. (For large systems it can take a long time to crunch +;;; through the code, so this can save some time.) +;;; +;;; ----- +;;; The following macros define new function and macro call patterns. +;;; They may be used to extend the static analysis tool to handle +;;; new def forms, extensions to Common Lisp, and program defs. +;;; +;;; DEFINE-PATTERN-SUBSTITUTION (name pattern) [MACRO] +;;; Defines NAME to be equivalent to the specified pattern. Useful for +;;; making patterns more readable. For example, the LAMBDA-LIST is +;;; defined as a pattern substitution, making the definition of the +;;; DEFUN caller-pattern simpler. +;;; +;;; DEFINE-CALLER-PATTERN (name pattern &optional caller-type) [MACRO] +;;; Defines NAME as a function/macro call with argument structure +;;; described by PATTERN. CALLER-TYPE, if specified, assigns a type to +;;; the pattern, which may be used to exclude references to NAME while +;;; viewing the database. For example, all the Common Lisp definitions +;;; have a caller-type of :lisp or :lisp2, so that you can exclude +;;; references to common lisp functions from the calling tree. +;;; +;;; DEFINE-VARIABLE-PATTERN (name &optional caller-type) [MACRO] +;;; Defines NAME as a variable reference of type CALLER-TYPE. This is +;;; mainly used to establish the caller-type of the variable. +;;; +;;; DEFINE-CALLER-PATTERN-SYNONYMS (source destinations) [MACRO] +;;; For defining function caller pattern syntax synonyms. For each name +;;; in DESTINATIONS, defines its pattern as a copy of the definition +;;; of SOURCE. Allows a large number of identical patterns to be defined +;;; simultaneously. Must occur after the SOURCE has been defined. +;;; +;;; ----- +;;; This system includes pattern definitions for the latest +;;; common lisp specification, as published in Guy Steele, +;;; Common Lisp: The Language, 2nd Edition. +;;; +;;; Patterns may be either structures to match, or a predicate +;;; like symbolp/numberp/stringp. The pattern specification language +;;; is similar to the notation used in CLtL2, but in a more lisp-like +;;; form: +;;; (:eq name) The form element must be eq to the symbol NAME. +;;; (:test test) TEST must be true when applied to the form element. +;;; (:typep type) The form element must be of type TYPE. +;;; (:or pat1 pat2 ...) Tries each of the patterns in left-to-right order, +;;; until one succeeds. +;;; Equivalent to { pat1 | pat2 | ... } +;;; (:rest pattern) The remaining form elements are grouped into a +;;; list which is matched against PATTERN. +;;; (:optional pat1 ...) The patterns may optionally match against the +;;; form element. +;;; Equivalent to [ pat1 ... ]. +;;; (:star pat1 ...) The patterns may match against the patterns +;;; any number of times, including 0. +;;; Equivalent to { pat1 ... }*. +;;; (:plus pat1 ...) The patterns may match against the patterns +;;; any number of times, but at least once. +;;; Equivalent to { pat1 ... }+. +;;; &optional, &key, Similar in behavior to the corresponding +;;; &rest lambda-list keywords. +;;; FORM A random lisp form. If a cons, assumes the +;;; car is a function or macro and tries to +;;; match the args against that symbol's pattern. +;;; If a symbol, assumes it's a variable reference. +;;; :ignore Ignores the corresponding form element. +;;; NAME The corresponding form element should be +;;; the name of a new definition (e.g., the +;;; first arg in a defun pattern is NAME. +;;; FUNCTION, MACRO The corresponding form element should be +;;; a function reference not handled by FORM. +;;; Used in the definition of apply and funcall. +;;; VAR The corresponding form element should be +;;; a variable definition or mutation. Used +;;; in the definition of let, let*, etc. +;;; VARIABLE The corresponding form element should be +;;; a variable reference. +;;; +;;; In all other pattern symbols, it looks up the symbols pattern substitution +;;; and recursively matches against the pattern. Automatically destructures +;;; list structure that does not include consing dots. +;;; +;;; Among the pattern substitution names defined are: +;;; STRING, SYMBOL, NUMBER Appropriate :test patterns. +;;; LAMBDA-LIST Matches against a lambda list. +;;; BODY Matches against a function body definition. +;;; FN Matches against #'function, 'function, +;;; and lambdas. This is used in the definition +;;; of apply, funcall, and the mapping patterns. +;;; and others... +;;; +;;; Here's some sample pattern definitions: +;;; (define-caller-pattern defun +;;; (name lambda-list +;;; (:star (:or documentation-string declaration)) +;;; (:star form)) +;;; :lisp) +;;; (define-caller-pattern funcall (fn (:star form)) :lisp) +;;; +;;; In general, the system is intelligent enough to handle any sort of +;;; simple funcall. One only need specify the syntax for functions and +;;; macros which use optional arguments, keyword arguments, or some +;;; argument positions are special, such as in apply and funcall, or +;;; to indicate that the function is of the specified caller type. +;;; +;;; +;;; NOTES: +;;; +;;; XRef assumes syntactically correct lisp code. +;;; +;;; This is by no means perfect. For example, let and let* are treated +;;; identically, instead of differentiating between serial and parallel +;;; binding. But it's still a useful tool. It can be helpful in +;;; maintaining code, debugging problems with patch files, determining +;;; whether functions are multiply defined, and help you remember where +;;; a function is defined or called. +;;; +;;; XREF runs best when compiled. + +;;; ******************************** +;;; References ********************* +;;; ******************************** +;;; +;;; Xerox Interlisp Masterscope Program: +;;; Larry M Masinter, Global program analysis in an interactive environment +;;; PhD Thesis, Stanford University, 1980. +;;; +;;; Symbolics Who-Calls Database: +;;; User's Guide to Symbolics Computers, Volume 1, Cambridge, MA, July 1986 +;;; Genera 7.0, pp 183-185. +;;; + +;;; ******************************** +;;; Example ************************ +;;; ******************************** +;;; +;;; Here is an example of running XREF on a short program. +;;; [In Scribe documentation, give a simple short program and resulting +;;; XREF output, including postscript call graphs.] +#| +<cl> (xref:xref-file "/afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp") +Cross-referencing file /afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp. +................................................ +48 forms processed. +<cl> (xref:display-database :readers) + +*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL. +*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE. +*WITHIN-LEVEL-SPACING* is referenced by BREADTH CALCULATE-POSITION-INFO. +*DIRECTION* is referenced by CREATE-POSITION-INFO. +*LINK-OFFSET* is referenced by OFFSET-OF-LINK-FROM-ATTACHMENT-POINT. +*ROOT-IS-SEQUENCE* is referenced by GRAPH. +*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE. +*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL. +*DEFAULT-GRAPH-POSITION* is referenced by CREATE-POSITION-INFO. +*GRAPHING-CUTOFF-DEPTH* is referenced by CREATE-NODE-STRUCTURE. +*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE. +*GRAPH-TYPE* is referenced by CREATE-NODE-STRUCTURE. +<cl> (xref:print-caller-trees :root-nodes '(display-graph)) + +Rooted calling trees: + DISPLAY-GRAPH + CREATE-POSITION-INFO + CALCULATE-POSITION-INFO + CALCULATE-POSITION + NODE-POSITION-ALREADY-SET-FLAG + NODE-LEVEL-ALREADY-SET-FLAG + CALCULATE-POSITION-IN-LEVEL + NODE-CHILDREN + NODE-LEVEL + CALCULATE-POSITION + NEW-CALCULATE-BREADTH + NODE-CHILDREN + BREADTH + OPPOSITE-DIMENSION + NODE-HEIGHT + NODE-WIDTH + NEW-CALCULATE-BREADTH + NODE-PARENTS + OPPOSITE-DIMENSION + NODE-HEIGHT + NODE-WIDTH + OPPOSITE-POSITION + NODE-Y + NODE-X + NODE-LEVEL + CALCULATE-LEVEL-POSITION + NODE-LEVEL + NODE-POSITION + NODE-X + NODE-Y + DIMENSION + NODE-WIDTH + NODE-HEIGHT + CALCULATE-LEVEL-POSITION-BEFORE + NODE-LEVEL + NODE-POSITION + NODE-X + NODE-Y + NODE-WIDTH + NODE-HEIGHT + DIMENSION + NODE-WIDTH + NODE-HEIGHT +|# + +;;; **************************************************************** +;;; List Callers *************************************************** +;;; **************************************************************** + +(defpackage :pxref + (:use :common-lisp) + (:export #:list-callers + #:list-users + #:list-readers + #:list-setters + #:what-files-call + #:who-calls + #:list-callees + #:source-file + #:clear-tables + #:define-pattern-substitution + #:define-caller-pattern + #:define-variable-pattern + #:define-caller-pattern-synonyms + #:clear-patterns + #:*last-form* + #:*xref-verbose* + #:*handle-package-forms* + #:*handle-function-forms* + #:*handle-macro-forms* + #:*types-to-ignore* + #:*last-caller-tree* + #:*default-graphing-mode* + #:*indent-amount* + #:xref-file + #:xref-files + #:write-callers-database-to-file + #:display-database + #:print-caller-trees + #:make-caller-tree + #:print-indented-tree + #:determine-file-dependencies + #:print-file-dependencies + #:psgraph-xref + )) + +(in-package "PXREF") + +;;; Warn user if they're loading the source instead of compiling it first. +;(eval-when (compile load eval) +; (defvar compiled-p nil)) +;(eval-when (compile load) +; (setq compiled-p t)) +;(eval-when (load eval) +; (unless compiled-p +; (warn "This file should be compiled before loading for best results."))) +(eval-when (eval) + (warn "This file should be compiled before loading for best results.")) + + +;;; ******************************** +;;; Primitives ********************* +;;; ******************************** +(defun lookup (symbol environment) + (dolist (frame environment) + (when (member symbol frame) + (return symbol)))) + +(defun car-eq (list item) + (and (consp list) + (eq (car list) item))) + +;;; ******************************** +;;; Callers Database *************** +;;; ******************************** +(defvar *file-callers-database* (make-hash-table :test #'equal) + "Contains name and list of file callers (files which call) for that name.") +(defvar *callers-database* (make-hash-table :test #'equal) + "Contains name and list of callers (function invocation) for that name.") +(defvar *readers-database* (make-hash-table :test #'equal) + "Contains name and list of readers (variable use) for that name.") +(defvar *setters-database* (make-hash-table :test #'equal) + "Contains name and list of setters (variable mutation) for that name.") +(defvar *callees-database* (make-hash-table :test #'equal) + "Contains name and list of functions and variables it calls.") +(defun callers-list (name &optional (database :callers)) + (case database + (:file (gethash name *file-callers-database*)) + (:callees (gethash name *callees-database*)) + (:callers (gethash name *callers-database*)) + (:readers (gethash name *readers-database*)) + (:setters (gethash name *setters-database*)))) +(defsetf callers-list (name &optional (database :callers)) (caller) + `(setf (gethash ,name (case ,database + (:file *file-callers-database*) + (:callees *callees-database*) + (:callers *callers-database*) + (:readers *readers-database*) + (:setters *setters-database*))) + ,caller)) + +(defun list-callers (symbol) + "Lists all functions which call SYMBOL as a function (function invocation)." + (callers-list symbol :callers)) +(defun list-readers (symbol) + "Lists all functions which refer to SYMBOL as a variable + (variable reference)." + (callers-list symbol :readers)) +(defun list-setters (symbol) + "Lists all functions which bind/set SYMBOL as a variable + (variable mutation)." + (callers-list symbol :setters)) +(defun list-users (symbol) + "Lists all functions which use SYMBOL as a variable or function." + (values (list-callers symbol) + (list-readers symbol) + (list-setters symbol))) +(defun who-calls (symbol &optional how) + "Lists callers of symbol. HOW may be :function, :reader, :setter, + or :variable." + ;; would be nice to have :macro and distinguish variable + ;; binding from assignment. (i.e., variable binding, assignment, and use) + (case how + (:function (list-callers symbol)) + (:reader (list-readers symbol)) + (:setter (list-setters symbol)) + (:variable (append (list-readers symbol) + (list-setters symbol))) + (otherwise (append (list-callers symbol) + (list-readers symbol) + (list-setters symbol))))) +(defun what-files-call (symbol) + "Lists names of files that contain uses of SYMBOL + as a function, variable, or constant." + (callers-list symbol :file)) +(defun list-callees (symbol) + "Lists names of functions and variables called by SYMBOL." + (callers-list symbol :callees)) + +(defvar *source-file* (make-hash-table :test #'equal) + "Contains function name and source file for that name.") +(defun source-file (symbol) + "Lists the names of files in which SYMBOL is defined/used." + (gethash symbol *source-file*)) +(defsetf source-file (name) (value) + `(setf (gethash ,name *source-file*) ,value)) + +(defun clear-tables () + (clrhash *file-callers-database*) + (clrhash *callers-database*) + (clrhash *callees-database*) + (clrhash *readers-database*) + (clrhash *setters-database*) + (clrhash *source-file*)) + + +;;; ******************************** +;;; Pattern Database *************** +;;; ******************************** +;;; Pattern Types +(defvar *pattern-caller-type* (make-hash-table :test #'equal)) +(defun pattern-caller-type (name) + (gethash name *pattern-caller-type*)) +(defsetf pattern-caller-type (name) (value) + `(setf (gethash ,name *pattern-caller-type*) ,value)) + +;;; Pattern Substitutions +(defvar *pattern-substitution-table* (make-hash-table :test #'equal) + "Stores general patterns for function destructuring.") +(defun lookup-pattern-substitution (name) + (gethash name *pattern-substitution-table*)) +(defmacro define-pattern-substitution (name pattern) + "Defines NAME to be equivalent to the specified pattern. Useful for + making patterns more readable. For example, the LAMBDA-LIST is + defined as a pattern substitution, making the definition of the + DEFUN caller-pattern simpler." + `(setf (gethash ',name *pattern-substitution-table*) + ',pattern)) + +;;; Function/Macro caller patterns: +;;; The car of the form is skipped, so we don't need to specify +;;; (:eq function-name) like we would for a substitution. +;;; +;;; Patterns must be defined in the XREF package because the pattern +;;; language is tested by comparing symbols (using #'equal) and not +;;; their printreps. This is fine for the lisp grammer, because the XREF +;;; package depends on the LISP package, so a symbol like 'xref::cons is +;;; translated automatically into 'lisp::cons. However, since +;;; (equal 'foo::bar 'baz::bar) returns nil unless both 'foo::bar and +;;; 'baz::bar are inherited from the same package (e.g., LISP), +;;; if package handling is turned on the user must specify package +;;; names in the caller pattern definitions for functions that occur +;;; in packages other than LISP, otherwise the symbols will not match. +;;; +;;; Perhaps we should enforce the definition of caller patterns in the +;;; XREF package by wrapping the body of define-caller-pattern in +;;; the XREF package: +;;; (defmacro define-caller-pattern (name value &optional caller-type) +;;; (let ((old-package *package*)) +;;; (setf *package* (find-package "XREF")) +;;; (prog1 +;;; `(progn +;;; (when ',caller-type +;;; (setf (pattern-caller-type ',name) ',caller-type)) +;;; (when ',value +;;; (setf (gethash ',name *caller-pattern-table*) +;;; ',value))) +;;; (setf *package* old-package)))) +;;; Either that, or for the purpose of pattern testing we should compare +;;; printreps. [The latter makes the primitive patterns like VAR +;;; reserved words.] +(defvar *caller-pattern-table* (make-hash-table :test #'equal) + "Stores patterns for function destructuring.") +(defun lookup-caller-pattern (name) + (gethash name *caller-pattern-table*)) +(defmacro define-caller-pattern (name pattern &optional caller-type) + "Defines NAME as a function/macro call with argument structure + described by PATTERN. CALLER-TYPE, if specified, assigns a type to + the pattern, which may be used to exclude references to NAME while + viewing the database. For example, all the Common Lisp definitions + have a caller-type of :lisp or :lisp2, so that you can exclude + references to common lisp functions from the calling tree." + `(progn + (when ',caller-type + (setf (pattern-caller-type ',name) ',caller-type)) + (when ',pattern + (setf (gethash ',name *caller-pattern-table*) + ',pattern)))) + +;;; For defining variables +(defmacro define-variable-pattern (name &optional caller-type) + "Defines NAME as a variable reference of type CALLER-TYPE. This is + mainly used to establish the caller-type of the variable." + `(progn + (when ',caller-type + (setf (pattern-caller-type ',name) ',caller-type)))) + +;;; For defining synonyms. Means much less space taken up by the patterns. +(defmacro define-caller-pattern-synonyms (source destinations) + "For defining function caller pattern syntax synonyms. For each name + in DESTINATIONS, defines its pattern as a copy of the definition of SOURCE. + Allows a large number of identical patterns to be defined simultaneously. + Must occur after the SOURCE has been defined." + `(let ((source-type (pattern-caller-type ',source)) + (source-pattern (gethash ',source *caller-pattern-table*))) + (when source-type + (dolist (dest ',destinations) + (setf (pattern-caller-type dest) source-type))) + (when source-pattern + (dolist (dest ',destinations) + (setf (gethash dest *caller-pattern-table*) + source-pattern))))) + +(defun clear-patterns () + (clrhash *pattern-substitution-table*) + (clrhash *caller-pattern-table*) + (clrhash *pattern-caller-type*)) + +;;; ******************************** +;;; Cross Reference Files ********** +;;; ******************************** +(defvar *last-form* () + "The last form read from the file. Useful for figuring out what went wrong + when xref-file drops into the debugger.") + +(defvar *xref-verbose* t + "When T, xref-file(s) prints out the names of the files it looks at, + progress dots, and the number of forms read.") + +;;; This needs to first clear the tables? +(defun xref-files (&rest files) + "Grovels over the lisp code located in source file FILES, using xref-file." + ;; If the arg is a list, use it. + (when (listp (car files)) (setq files (car files))) + (dolist (file files) + (xref-file file nil)) + (values)) + +(defvar *handle-package-forms* nil ;'(lisp::in-package) + "When non-NIL, and XREF-FILE sees a package-setting form like IN-PACKAGE, + sets the current package to the specified package by evaluating the + form. When done with the file, xref-file resets the package to its + original value. In some of the displaying functions, when this variable + is non-NIL one may specify that all symbols from a particular set of + packages be ignored. This is only useful if the files use different + packages with conflicting names.") + +(defvar *normal-readtable* (copy-readtable nil) + "Normal, unadulterated CL readtable.") + +(defun xref-file (filename &optional (clear-tables t) (verbose *xref-verbose*)) + "Cross references the function and variable calls in FILENAME by + walking over the source code located in the file. Defaults type of + filename to \".lisp\". Chomps on the code using record-callers and + record-callers*. If CLEAR-TABLES is T (the default), it clears the callers + database before processing the file. Specify CLEAR-TABLES as nil to + append to the database. If VERBOSE is T (the default), prints out the + name of the file, one progress dot for each form processed, and the + total number of forms." + ;; Default type to "lisp" + (when (and (null (pathname-type filename)) + (not (probe-file filename))) + (cond ((stringp filename) + (setf filename (concatenate 'string filename ".lisp"))) + ((pathnamep filename) + (setf filename (merge-pathnames filename + (make-pathname :type "lisp")))))) + (when clear-tables (clear-tables)) + (let ((count 0) + (old-package *package*) + (*readtable* *normal-readtable*)) + (when verbose + (format t "~&Cross-referencing file ~A.~&" filename)) + (with-open-file (stream filename :direction :input) + (do ((form (read stream nil :eof) (read stream nil :eof))) + ((eq form :eof)) + (incf count) + (when verbose + (format *standard-output* ".") + (force-output *standard-output*)) + (setq *last-form* form) + (record-callers filename form) + ;; Package Magic. + (when (and *handle-package-forms* + (consp form) + (member (car form) *handle-package-forms*)) + (eval form)))) + (when verbose + (format t "~&~D forms processed." count)) + (setq *package* old-package) + (values))) + +(defvar *handle-function-forms* t + "When T, XREF-FILE tries to be smart about forms which occur in + a function position, such as lambdas and arbitrary Lisp forms. + If so, it recursively calls record-callers with pattern 'FORM. + If the form is a lambda, makes the caller a caller of :unnamed-lambda.") + +(defvar *handle-macro-forms* t + "When T, if the file was loaded before being processed by XREF, and the + car of a form is a macro, it notes that the parent calls the macro, + and then calls macroexpand-1 on the form.") + +(defvar *callees-database-includes-variables* nil) + +(defun record-callers (filename form + &optional pattern parent (environment nil) + funcall) + "RECORD-CALLERS is the main routine used to walk down the code. It matches + the PATTERN against the FORM, possibly adding statements to the database. + PARENT is the name defined by the current outermost definition; it is + the caller of the forms in the body (e.g., FORM). ENVIRONMENT is used + to keep track of the scoping of variables. FUNCALL deals with the type + of variable assignment and hence how the environment should be modified. + RECORD-CALLERS handles atomic patterns and simple list-structure patterns. + For complex list-structure pattern destructuring, it calls RECORD-CALLERS*." +; (when form) + (unless pattern (setq pattern 'FORM)) + (cond ((symbolp pattern) + (case pattern + (:IGNORE + ;; Ignores the rest of the form. + (values t parent environment)) + (NAME + ;; This is the name of a new definition. + (push filename (source-file form)) + (values t form environment)) + ((FUNCTION MACRO) + ;; This is the name of a call. + (cond ((and *handle-function-forms* (consp form)) + ;; If we're a cons and special handling is on, + (when (eq (car form) 'lambda) + (pushnew filename (callers-list :unnamed-lambda :file)) + (when parent + (pushnew parent (callers-list :unnamed-lambda + :callers)) + (pushnew :unnamed-lambda (callers-list parent + :callees)))) + (record-callers filename form 'form parent environment)) + (t + ;; If we're just a regular function name call. + (pushnew filename (callers-list form :file)) + (when parent + (pushnew parent (callers-list form :callers)) + (pushnew form (callers-list parent :callees))) + (values t parent environment)))) + (VAR + ;; This is the name of a new variable definition. + ;; Includes arglist parameters. + (when (and (symbolp form) (not (keywordp form)) + (not (member form lambda-list-keywords))) + (pushnew form (car environment)) + (pushnew filename (callers-list form :file)) + (when parent +; (pushnew form (callers-list parent :callees)) + (pushnew parent (callers-list form :setters))) + (values t parent environment))) + (VARIABLE + ;; VAR reference + (pushnew filename (callers-list form :file)) + (when (and parent (not (lookup form environment))) + (pushnew parent (callers-list form :readers)) + (when *callees-database-includes-variables* + (pushnew form (callers-list parent :callees)))) + (values t parent environment)) + (FORM + ;; A random form (var or funcall). + (cond ((consp form) + ;; Get new pattern from TAG. + (let ((new-pattern (lookup-caller-pattern (car form)))) + (pushnew filename (callers-list (car form) :file)) + (when parent + (pushnew parent (callers-list (car form) :callers)) + (pushnew (car form) (callers-list parent :callees))) + (cond ((and new-pattern (cdr form)) + ;; Special Pattern and there's stuff left + ;; to be processed. Note that we check if + ;; a pattern is defined for the form before + ;; we check to see if we can macroexpand it. + (record-callers filename (cdr form) new-pattern + parent environment :funcall)) + ((and *handle-macro-forms* + (symbolp (car form)) ; pnorvig 9/9/93 + (macro-function (car form))) + ;; The car of the form is a macro and + ;; macro processing is turned on. Macroexpand-1 + ;; the form and try again. + (record-callers filename + (macroexpand-1 form) + 'form parent environment + :funcall)) + ((null (cdr form)) + ;; No more left to be processed. Note that + ;; this must occur after the macros clause, + ;; since macros can expand into more code. + (values t parent environment)) + (t + ;; Random Form. We assume it is a function call. + (record-callers filename (cdr form) + '((:star FORM)) + parent environment :funcall))))) + (t + (when (and (not (lookup form environment)) + (not (numberp form)) + ;; the following line should probably be + ;; commented out? + (not (keywordp form)) + (not (stringp form)) + (not (eq form t)) + (not (eq form nil))) + (pushnew filename (callers-list form :file)) + ;; ??? :callers + (when parent + (pushnew parent (callers-list form :readers)) + (when *callees-database-includes-variables* + (pushnew form (callers-list parent :callees))))) + (values t parent environment)))) + (otherwise + ;; Pattern Substitution + (let ((new-pattern (lookup-pattern-substitution pattern))) + (if new-pattern + (record-callers filename form new-pattern + parent environment) + (when (eq pattern form) + (values t parent environment))))))) + ((consp pattern) + (case (car pattern) + (:eq (when (eq (second pattern) form) + (values t parent environment))) + (:test (when (funcall (eval (second pattern)) form) + (values t parent environment))) + (:typep (when (typep form (second pattern)) + (values t parent environment))) + (:or (dolist (subpat (rest pattern)) + (multiple-value-bind (processed parent environment) + (record-callers filename form subpat + parent environment) + (when processed + (return (values processed parent environment)))))) + (:rest ; (:star :plus :optional :rest) + (record-callers filename form (second pattern) + parent environment)) + (otherwise + (multiple-value-bind (d p env) + (record-callers* filename form pattern + parent (cons nil environment)) + (values d p (if funcall environment env)))))))) + +(defun record-callers* (filename form pattern parent environment + &optional continuation + in-optionals in-keywords) + "RECORD-CALLERS* handles complex list-structure patterns, such as + ordered lists of subpatterns, patterns involving :star, :plus, + &optional, &key, &rest, and so on. CONTINUATION is a stack of + unprocessed patterns, IN-OPTIONALS and IN-KEYWORDS are corresponding + stacks which determine whether &rest or &key has been seen yet in + the current pattern." + ;; form must be a cons or nil. +; (when form) + (if (null pattern) + (if (null continuation) + (values t parent environment) + (record-callers* filename form (car continuation) parent environment + (cdr continuation) + (cdr in-optionals) + (cdr in-keywords))) + (let ((pattern-elt (car pattern))) + (cond ((car-eq pattern-elt :optional) + (if (null form) + (values t parent environment) + (multiple-value-bind (processed par env) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons (cdr pattern) continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords)) + (if processed + (values processed par env) + (record-callers* filename form (cdr pattern) + parent environment continuation + in-optionals in-keywords))))) + ((car-eq pattern-elt :star) + (if (null form) + (values t parent environment) + (multiple-value-bind (processed par env) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons pattern continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords)) + (if processed + (values processed par env) + (record-callers* filename form (cdr pattern) + parent environment continuation + in-optionals in-keywords))))) + ((car-eq pattern-elt :plus) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons (cons (cons :star (cdr pattern-elt)) + (cdr pattern)) + continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords))) + ((car-eq pattern-elt :rest) + (record-callers filename form pattern-elt parent environment)) + ((eq pattern-elt '&optional) + (record-callers* filename form (cdr pattern) + parent environment continuation + (cons t in-optionals) + (cons (car in-keywords) in-keywords))) + ((eq pattern-elt '&rest) + (record-callers filename form (second pattern) + parent environment)) + ((eq pattern-elt '&key) + (record-callers* filename form (cdr pattern) + parent environment continuation + (cons (car in-optionals) in-optionals) + (cons t in-keywords))) + ((null form) + (when (or (car in-keywords) (car in-optionals)) + (values t parent environment))) + ((consp form) + (multiple-value-bind (processed parent environment) + (record-callers filename (if (car in-keywords) + (cadr form) + (car form)) + pattern-elt + parent environment) + (cond (processed + (record-callers* filename (if (car in-keywords) + (cddr form) + (cdr form)) + (cdr pattern) + parent environment + continuation + in-optionals in-keywords)) + ((or (car in-keywords) + (car in-optionals)) + (values t parent environment))))))))) + + +;;; ******************************** +;;; Misc Utilities ***************** +;;; ******************************** +(defvar *types-to-ignore* + '(:lisp ; CLtL 1st Edition + :lisp2 ; CLtL 2nd Edition additional patterns + ) + "Default set of caller types (as specified in the patterns) to ignore + in the database handling functions. :lisp is CLtL 1st edition, + :lisp2 is additional patterns from CLtL 2nd edition.") + +(defun display-database (&optional (database :callers) + (types-to-ignore *types-to-ignore*)) + "Prints out the name of each symbol and all its callers. Specify database + :callers (the default) to get function call references, :fill to the get + files in which the symbol is called, :readers to get variable references, + and :setters to get variable binding and assignments. Ignores functions + of types listed in types-to-ignore." + (maphash #'(lambda (name callers) + (unless (or (member (pattern-caller-type name) + types-to-ignore) + ;; When we're doing fancy package crap, + ;; allow us to ignore symbols based on their + ;; packages. + (when *handle-package-forms* + (member (symbol-package name) + types-to-ignore + :key #'find-package))) + (format t "~&~S is referenced by~{ ~S~}." + name callers))) + (ecase database + (:file *file-callers-database*) + (:callers *callers-database*) + (:readers *readers-database*) + (:setters *setters-database*)))) + +(defun write-callers-database-to-file (filename) + "Saves the contents of the current callers database to a file. This + file can be loaded to restore the previous contents of the + database. (For large systems it can take a long time to crunch + through the code, so this can save some time.)" + (with-open-file (stream filename :direction :output) + (format stream "~&(clear-tables)") + (maphash #'(lambda (x y) + (format stream "~&(setf (source-file '~S) '~S)" + x y)) + *source-file*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :file) '~S)" + x y)) + *file-callers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :callers) '~S)" + x y)) + *callers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :callees) '~S)" + x y)) + *callees-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :readers) '~S)" + x y)) + *readers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :setters) '~S)" + x y)) + *setters-database*))) + + +;;; ******************************** +;;; Print Caller Trees ************* +;;; ******************************** +;;; The following function is useful for reversing a caller table into +;;; a callee table. Possibly later we'll extend xref to create two +;;; such database hash tables. Needs to include vars as well. +(defun invert-hash-table (table &optional (types-to-ignore *types-to-ignore*)) + "Makes a copy of the hash table in which (name value*) pairs + are inverted to (value name*) pairs." + (let ((target (make-hash-table :test #'equal))) + (maphash #'(lambda (key values) + (dolist (value values) + (unless (member (pattern-caller-type key) + types-to-ignore) + (pushnew key (gethash value target))))) + table) + target)) + +;;; Resolve file references for automatic creation of a defsystem file. +(defun determine-file-dependencies (&optional (database *callers-database*)) + "Makes a hash table of file dependencies for the references listed in + DATABASE. This function may be useful for automatically resolving + file references for automatic creation of a system definition (defsystem)." + (let ((file-ref-ht (make-hash-table :test #'equal))) + (maphash #'(lambda (key values) + (let ((key-file (source-file key))) + (when key + (dolist (value values) + (let ((value-file (source-file value))) + (when value-file + (dolist (s key-file) + (dolist (d value-file) + (pushnew d (gethash s file-ref-ht)))))))))) + database) + file-ref-ht)) + +(defun print-file-dependencies (&optional (database *callers-database*)) + "Prints a list of file dependencies for the references listed in DATABASE. + This function may be useful for automatically computing file loading + constraints for a system definition tool." + (maphash #'(lambda (key value) (format t "~&~S --> ~S" key value)) + (determine-file-dependencies database))) + +;;; The following functions demonstrate a possible way to interface +;;; xref to a graphical browser such as psgraph to mimic the capabilities +;;; of Masterscope's graphical browser. + +(defvar *last-caller-tree* nil) + +(defvar *default-graphing-mode* :call-graph + "Specifies whether we graph up or down. If :call-graph, the children + of a node are the functions it calls. If :caller-graph, the children + of a node are the functions that call it.") + +(defun gather-tree (parents &optional already-seen + (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) compact) + "Extends the tree, copying it into list structure, until it repeats + a reference (hits a cycle)." + (let ((*already-seen* nil) + (database (case mode + (:call-graph *callees-database*) + (:caller-graph *callers-database*)))) + (declare (special *already-seen*)) + (labels + ((amass-tree + (parents &optional already-seen) + (let (result this-item) + (dolist (parent parents) + (unless (member (pattern-caller-type parent) + types-to-ignore) + (pushnew parent *already-seen*) + (if (member parent already-seen) + (setq this-item nil) ; :ignore + (if compact + (multiple-value-setq (this-item already-seen) + (amass-tree (gethash parent database) + (cons parent already-seen))) + (setq this-item + (amass-tree (gethash parent database) + (cons parent already-seen))))) + (setq parent (format nil "~S" parent)) + (when (consp parent) (setq parent (cons :xref-list parent))) + (unless (eq this-item :ignore) + (push (if this-item + (list parent this-item) + parent) + result)))) + (values result ;(reverse result) + already-seen)))) + (values (amass-tree parents already-seen) + *already-seen*)))) + +(defun find-roots-and-cycles (&optional (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*)) + "Returns a list of uncalled callers (roots) and called callers (potential + cycles)." + (let ((uncalled-callers nil) + (called-callers nil) + (database (ecase mode + (:call-graph *callers-database*) + (:caller-graph *callees-database*))) + (other-database (ecase mode + (:call-graph *callees-database*) + (:caller-graph *callers-database*)))) + (maphash #'(lambda (name value) + (declare (ignore value)) + (unless (member (pattern-caller-type name) + types-to-ignore) + (if (gethash name database) + (push name called-callers) + (push name uncalled-callers)))) + other-database) + (values uncalled-callers called-callers))) + +(defun make-caller-tree (&optional (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) compact) + "Outputs list structure of a tree which roughly represents the possibly + cyclical structure of the caller database. + If mode is :call-graph, the children of a node are the functions it calls. + If mode is :caller-graph, the children of a node are the functions that + call it. + If compact is T, tries to eliminate the already-seen nodes, so that + the graph for a node is printed at most once. Otherwise it will duplicate + the node's tree (except for cycles). This is usefull because the call tree + is actually a directed graph, so we can either duplicate references or + display only the first one." + ;; Would be nice to print out line numbers and whenever we skip a duplicated + ;; reference, print the line number of the full reference after the node. + (multiple-value-bind (uncalled-callers called-callers) + (find-roots-and-cycles mode types-to-ignore) + (multiple-value-bind (trees already-seen) + (gather-tree uncalled-callers nil mode types-to-ignore compact) + (setq *last-caller-tree* trees) + (let ((more-trees (gather-tree (set-difference called-callers + already-seen) + already-seen + mode types-to-ignore compact))) + (values trees more-trees))))) + +(defvar *indent-amount* 3 + "Number of spaces to indent successive levels in PRINT-INDENTED-TREE.") + +(defun print-indented-tree (trees &optional (indent 0)) + "Simple code to print out a list-structure tree (such as those created + by make-caller-tree) as indented text." + (when trees + (dolist (tree trees) + (cond ((and (listp tree) (eq (car tree) :xref-list)) + (format t "~&~VT~A" indent (cdr tree))) + ((listp tree) + (format t "~&~VT~A" indent (car tree)) + (print-indented-tree (cadr tree) (+ indent *indent-amount*))) + (t + (format t "~&~VT~A" indent tree)))))) + +(defun print-caller-trees (&key (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) + compact + root-nodes) + "Prints the calling trees (which may actually be a full graph and not + necessarily a DAG) as indented text trees using PRINT-INDENTED-TREE. + MODE is :call-graph for trees where the children of a node are the + functions called by the node, or :caller-graph for trees where the + children of a node are the functions the node calls. TYPES-TO-IGNORE + is a list of funcall types (as specified in the patterns) to ignore + in printing out the database. For example, '(:lisp) would ignore all + calls to common lisp functions. COMPACT is a flag to tell the program + to try to compact the trees a bit by not printing trees if they have + already been seen. ROOT-NODES is a list of root nodes of trees to + display. If ROOT-NODES is nil, tries to find all root nodes in the + database." + (multiple-value-bind (rooted cycles) + (if root-nodes + (values (gather-tree root-nodes nil mode types-to-ignore compact)) + (make-caller-tree mode types-to-ignore compact)) + (when rooted + (format t "~&Rooted calling trees:") + (print-indented-tree rooted 2)) + (when cycles + (when rooted + (format t "~2%")) + (format t "~&Cyclic calling trees:") + (print-indented-tree cycles 2)))) + + +;;; ******************************** +;;; Interface to PSGraph *********** +;;; ******************************** +#| +;;; Interface to Bates' PostScript Graphing Utility +(load "/afs/cs/user/mkant/Lisp/PSGraph/psgraph") + +(defparameter *postscript-output-directory* "") +(defun psgraph-xref (&key (mode *default-graphing-mode*) + (output-directory *postscript-output-directory*) + (types-to-ignore *types-to-ignore*) + (compact t) + (shrink t) + root-nodes + insert) + ;; If root-nodes is a non-nil list, uses that list as the starting + ;; position. Otherwise tries to find all roots in the database. + (multiple-value-bind (rooted cycles) + (if root-nodes + (values (gather-tree root-nodes nil mode types-to-ignore compact)) + (make-caller-tree mode types-to-ignore compact)) + (psgraph-output (append rooted cycles) output-directory shrink insert))) + +(defun psgraph-output (list-of-trees directory shrink &optional insert) + (let ((psgraph:*fontsize* 9) + (psgraph:*second-fontsize* 7) +; (psgraph:*boxkind* "fill") + (psgraph:*boxgray* "0") ; .8 + (psgraph:*edgewidth* "1") + (psgraph:*edgegray* "0")) + (labels ((stringify (thing) + (cond ((stringp thing) (string-downcase thing)) + ((symbolp thing) (string-downcase (symbol-name thing))) + ((and (listp thing) (eq (car thing) :xref-list)) + (stringify (cdr thing))) + ((listp thing) (stringify (car thing))) + (t (string thing))))) + (dolist (item list-of-trees) + (let* ((fname (stringify item)) + (filename (concatenate 'string directory + (string-trim '(#\: #\|) fname) + ".ps"))) + (format t "~&Creating PostScript file ~S." filename) + (with-open-file (*standard-output* filename + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + ;; Note that the #'eq prints the DAG as a tree. If + ;; you replace it with #'equal, it will print it as + ;; a DAG, which I think is slightly ugly. + (psgraph:psgraph item + #'caller-tree-children #'caller-info shrink + insert #'eq))))))) + +(defun caller-tree-children (tree) + (when (and tree (listp tree) (not (eq (car tree) :xref-list))) + (cadr tree))) + +(defun caller-tree-node (tree) + (when tree + (cond ((and (listp tree) (eq (car tree) :xref-list)) + (cdr tree)) + ((listp tree) + (car tree)) + (t + tree)))) + +(defun caller-info (tree) + (let ((node (caller-tree-node tree))) + (list node))) +|# +#| +;;; Code to print out graphical trees of CLOS class hierarchies. +(defun print-class-hierarchy (&optional (start-class 'anything) + (file "classes.ps")) + (let ((start (find-class start-class))) + (when start + (with-open-file (*standard-output* file :direction :output) + (psgraph:psgraph start + #'clos::class-direct-subclasses + #'(lambda (x) + (list (format nil "~A" (clos::class-name x)))) + t nil #'eq))))) + +|# + + +;;; **************************************************************** +;;; Cross Referencing Patterns for Common Lisp ********************* +;;; **************************************************************** +(clear-patterns) + +;;; ******************************** +;;; Pattern Substitutions ********** +;;; ******************************** +(define-pattern-substitution integer (:test #'integerp)) +(define-pattern-substitution rational (:test #'rationalp)) +(define-pattern-substitution symbol (:test #'symbolp)) +(define-pattern-substitution string (:test #'stringp)) +(define-pattern-substitution number (:test #'numberp)) +(define-pattern-substitution lambda-list + ((:star var) + (:optional (:eq &optional) + (:star (:or var + (var (:optional form (:optional var)))))) + (:optional (:eq &rest) var) + (:optional (:eq &key) (:star (:or var + ((:or var + (keyword var)) + (:optional form (:optional var))))) + (:optional &allow-other-keys)) + (:optional (:eq &aux) + (:star (:or var + (var (:optional form))))))) +(define-pattern-substitution test form) +(define-pattern-substitution body + ((:star (:or declaration documentation-string)) + (:star form))) +(define-pattern-substitution documentation-string string) +(define-pattern-substitution initial-value form) +(define-pattern-substitution tag symbol) +(define-pattern-substitution declaration ((:eq declare)(:rest :ignore))) +(define-pattern-substitution destination form) +(define-pattern-substitution control-string string) +(define-pattern-substitution format-arguments + ((:star form))) +(define-pattern-substitution fn + (:or ((:eq quote) function) + ((:eq function) function) + function)) + +;;; ******************************** +;;; Caller Patterns **************** +;;; ******************************** + +;;; Types Related +(define-caller-pattern coerce (form :ignore) :lisp) +(define-caller-pattern type-of (form) :lisp) +(define-caller-pattern upgraded-array-element-type (:ignore) :lisp2) +(define-caller-pattern upgraded-complex-part-type (:ignore) :lisp2) + +;;; Lambdas and Definitions +(define-variable-pattern lambda-list-keywords :lisp) +(define-variable-pattern lambda-parameters-limit :lisp) +(define-caller-pattern lambda (lambda-list (:rest body)) :lisp) + +(define-caller-pattern defun + (name lambda-list + (:star (:or documentation-string declaration)) + (:star form)) + :lisp) + +;;; perhaps this should use VAR, instead of NAME +(define-caller-pattern defvar + (var (:optional initial-value (:optional documentation-string))) + :lisp) +(define-caller-pattern defparameter + (var initial-value (:optional documentation-string)) + :lisp) +(define-caller-pattern defconstant + (var initial-value (:optional documentation-string)) + :lisp) + +(define-caller-pattern eval-when + (:ignore ; the situations + (:star form)) + :lisp) + +;;; Logical Values +(define-variable-pattern nil :lisp) +(define-variable-pattern t :lisp) + +;;; Predicates +(define-caller-pattern typep (form form) :lisp) +(define-caller-pattern subtypep (form form) :lisp) + +(define-caller-pattern null (form) :lisp) +(define-caller-pattern symbolp (form) :lisp) +(define-caller-pattern atom (form) :lisp) +(define-caller-pattern consp (form) :lisp) +(define-caller-pattern listp (form) :lisp) +(define-caller-pattern numberp (form) :lisp) +(define-caller-pattern integerp (form) :lisp) +(define-caller-pattern rationalp (form) :lisp) +(define-caller-pattern floatp (form) :lisp) +(define-caller-pattern realp (form) :lisp2) +(define-caller-pattern complexp (form) :lisp) +(define-caller-pattern characterp (form) :lisp) +(define-caller-pattern stringp (form) :lisp) +(define-caller-pattern bit-vector-p (form) :lisp) +(define-caller-pattern vectorp (form) :lisp) +(define-caller-pattern simple-vector-p (form) :lisp) +(define-caller-pattern simple-string-p (form) :lisp) +(define-caller-pattern simple-bit-vector-p (form) :lisp) +(define-caller-pattern arrayp (form) :lisp) +(define-caller-pattern packagep (form) :lisp) +(define-caller-pattern functionp (form) :lisp) +(define-caller-pattern compiled-function-p (form) :lisp) +(define-caller-pattern commonp (form) :lisp) + +;;; Equality Predicates +(define-caller-pattern eq (form form) :lisp) +(define-caller-pattern eql (form form) :lisp) +(define-caller-pattern equal (form form) :lisp) +(define-caller-pattern equalp (form form) :lisp) + +;;; Logical Operators +(define-caller-pattern not (form) :lisp) +(define-caller-pattern or ((:star form)) :lisp) +(define-caller-pattern and ((:star form)) :lisp) + +;;; Reference + +;;; Quote is a problem. In Defmacro & friends, we'd like to actually +;;; look at the argument, 'cause it hides internal function calls +;;; of the defmacro. +(define-caller-pattern quote (:ignore) :lisp) + +(define-caller-pattern function ((:or fn form)) :lisp) +(define-caller-pattern symbol-value (form) :lisp) +(define-caller-pattern symbol-function (form) :lisp) +(define-caller-pattern fdefinition (form) :lisp2) +(define-caller-pattern boundp (form) :lisp) +(define-caller-pattern fboundp (form) :lisp) +(define-caller-pattern special-form-p (form) :lisp) + +;;; Assignment +(define-caller-pattern setq ((:star var form)) :lisp) +(define-caller-pattern psetq ((:star var form)) :lisp) +(define-caller-pattern set (form form) :lisp) +(define-caller-pattern makunbound (form) :lisp) +(define-caller-pattern fmakunbound (form) :lisp) + +;;; Generalized Variables +(define-caller-pattern setf ((:star form form)) :lisp) +(define-caller-pattern psetf ((:star form form)) :lisp) +(define-caller-pattern shiftf ((:plus form) form) :lisp) +(define-caller-pattern rotatef ((:star form)) :lisp) +(define-caller-pattern define-modify-macro + (name + lambda-list + fn + (:optional documentation-string)) + :lisp) +(define-caller-pattern defsetf + (:or (name name (:optional documentation-string)) + (name lambda-list (var) + (:star (:or declaration documentation-string)) + (:star form))) + :lisp) +(define-caller-pattern define-setf-method + (name lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp) +(define-caller-pattern get-setf-method (form) :lisp) +(define-caller-pattern get-setf-method-multiple-value (form) :lisp) + + +;;; Function invocation +(define-caller-pattern apply (fn form (:star form)) :lisp) +(define-caller-pattern funcall (fn (:star form)) :lisp) + + +;;; Simple sequencing +(define-caller-pattern progn ((:star form)) :lisp) +(define-caller-pattern prog1 (form (:star form)) :lisp) +(define-caller-pattern prog2 (form form (:star form)) :lisp) + +;;; Variable bindings +(define-caller-pattern let + (((:star (:or var (var &optional form)))) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern let* + (((:star (:or var (var &optional form)))) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern compiler-let + (((:star (:or var (var form)))) + (:star form)) + :lisp) +(define-caller-pattern progv + (form form (:star form)) :lisp) +(define-caller-pattern flet + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern labels + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern macrolet + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern symbol-macrolet + (((:star (var form))) (:star declaration) (:star form)) + :lisp2) + +;;; Conditionals +(define-caller-pattern if (test form (:optional form)) :lisp) +(define-caller-pattern when (test (:star form)) :lisp) +(define-caller-pattern unless (test (:star form)) :lisp) +(define-caller-pattern cond ((:star (test (:star form)))) :lisp) +(define-caller-pattern case + (form + (:star ((:or symbol + ((:star symbol))) + (:star form)))) + :lisp) +(define-caller-pattern typecase (form (:star (symbol (:star form)))) + :lisp) + +;;; Blocks and Exits +(define-caller-pattern block (name (:star form)) :lisp) +(define-caller-pattern return-from (function (:optional form)) :lisp) +(define-caller-pattern return ((:optional form)) :lisp) + +;;; Iteration +(define-caller-pattern loop ((:star form)) :lisp) +(define-caller-pattern do + (((:star (:or var + (var (:optional form (:optional form)))))) ; init step + (form (:star form)) ; end-test result + (:star declaration) + (:star (:or tag form))) ; statement + :lisp) +(define-caller-pattern do* + (((:star (:or var + (var (:optional form (:optional form)))))) + (form (:star form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern dolist + ((var form (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern dotimes + ((var form (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) + +;;; Mapping +(define-caller-pattern mapcar (fn form (:star form)) :lisp) +(define-caller-pattern maplist (fn form (:star form)) :lisp) +(define-caller-pattern mapc (fn form (:star form)) :lisp) +(define-caller-pattern mapl (fn form (:star form)) :lisp) +(define-caller-pattern mapcan (fn form (:star form)) :lisp) +(define-caller-pattern mapcon (fn form (:star form)) :lisp) + +;;; The "Program Feature" +(define-caller-pattern tagbody ((:star (:or tag form))) :lisp) +(define-caller-pattern prog + (((:star (:or var (var (:optional form))))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern prog* + (((:star (:or var (var (:optional form))))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern go (tag) :lisp) + +;;; Multiple Values +(define-caller-pattern values ((:star form)) :lisp) +(define-variable-pattern multiple-values-limit :lisp) +(define-caller-pattern values-list (form) :lisp) +(define-caller-pattern multiple-value-list (form) :lisp) +(define-caller-pattern multiple-value-call (fn (:star form)) :lisp) +(define-caller-pattern multiple-value-prog1 (form (:star form)) :lisp) +(define-caller-pattern multiple-value-bind + (((:star var)) form + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern multiple-value-setq (((:star var)) form) :lisp) +(define-caller-pattern nth-value (form form) :lisp2) + +;;; Dynamic Non-Local Exits +(define-caller-pattern catch (tag (:star form)) :lisp) +(define-caller-pattern throw (tag form) :lisp) +(define-caller-pattern unwind-protect (form (:star form)) :lisp) + +;;; Macros +(define-caller-pattern macro-function (form) :lisp) +(define-caller-pattern defmacro + (name + lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp) +(define-caller-pattern macroexpand (form (:optional :ignore)) :lisp) +(define-caller-pattern macroexpand-1 (form (:optional :ignore)) :lisp) +(define-variable-pattern *macroexpand-hook* :lisp) + +;;; Destructuring +(define-caller-pattern destructuring-bind + (lambda-list form + (:star declaration) + (:star form)) + :lisp2) + +;;; Compiler Macros +(define-caller-pattern define-compiler-macro + (name lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern compiler-macro-function (form) :lisp2) +(define-caller-pattern compiler-macroexpand (form (:optional :ignore)) :lisp2) +(define-caller-pattern compiler-macroexpand-1 (form (:optional :ignore)) :lisp2) + +;;; Environments +(define-caller-pattern variable-information (form &optional :ignore) + :lisp2) +(define-caller-pattern function-information (fn &optional :ignore) :lisp2) +(define-caller-pattern declaration-information (form &optional :ignore) :lisp2) +(define-caller-pattern augment-environment (form &key (:star :ignore)) :lisp2) +(define-caller-pattern define-declaration + (name + lambda-list + (:star form)) + :lisp2) +(define-caller-pattern parse-macro (name lambda-list form) :lisp2) +(define-caller-pattern enclose (form &optional :ignore) :lisp2) + + +;;; Declarations +(define-caller-pattern declare ((:rest :ignore)) :lisp) +(define-caller-pattern proclaim ((:rest :ignore)) :lisp) +(define-caller-pattern locally ((:star declaration) (:star form)) :lisp) +(define-caller-pattern declaim ((:rest :ignore)) :lisp2) +(define-caller-pattern the (form form) :lisp) + +;;; Symbols +(define-caller-pattern get (form form (:optional form)) :lisp) +(define-caller-pattern remprop (form form) :lisp) +(define-caller-pattern symbol-plist (form) :lisp) +(define-caller-pattern getf (form form (:optional form)) :lisp) +(define-caller-pattern remf (form form) :lisp) +(define-caller-pattern get-properties (form form) :lisp) + +(define-caller-pattern symbol-name (form) :lisp) +(define-caller-pattern make-symbol (form) :lisp) +(define-caller-pattern copy-symbol (form (:optional :ignore)) :lisp) +(define-caller-pattern gensym ((:optional :ignore)) :lisp) +(define-variable-pattern *gensym-counter* :lisp2) +(define-caller-pattern gentemp ((:optional :ignore :ignore)) :lisp) +(define-caller-pattern symbol-package (form) :lisp) +(define-caller-pattern keywordp (form) :lisp) + +;;; Packages +(define-variable-pattern *package* :lisp) +(define-caller-pattern make-package ((:rest :ignore)) :lisp) +(define-caller-pattern in-package ((:rest :ignore)) :lisp) +(define-caller-pattern find-package ((:rest :ignore)) :lisp) +(define-caller-pattern package-name ((:rest :ignore)) :lisp) +(define-caller-pattern package-nicknames ((:rest :ignore)) :lisp) +(define-caller-pattern rename-package ((:rest :ignore)) :lisp) +(define-caller-pattern package-use-list ((:rest :ignore)) :lisp) +(define-caller-pattern package-used-by-list ((:rest :ignore)) :lisp) +(define-caller-pattern package-shadowing-symbols ((:rest :ignore)) :lisp) +(define-caller-pattern list-all-packages () :lisp) +(define-caller-pattern delete-package ((:rest :ignore)) :lisp2) +(define-caller-pattern intern (form &optional :ignore) :lisp) +(define-caller-pattern find-symbol (form &optional :ignore) :lisp) +(define-caller-pattern unintern (form &optional :ignore) :lisp) + +(define-caller-pattern export ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern unexport ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern import ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern shadowing-import ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern shadow ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) + +(define-caller-pattern use-package ((:rest :ignore)) :lisp) +(define-caller-pattern unuse-package ((:rest :ignore)) :lisp) +(define-caller-pattern defpackage (name (:rest :ignore)) :lisp2) +(define-caller-pattern find-all-symbols (form) :lisp) +(define-caller-pattern do-symbols + ((var (:optional form (:optional form))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern do-external-symbols + ((var (:optional form (:optional form))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern do-all-symbols + ((var (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern with-package-iterator + ((name form (:plus :ignore)) + (:star form)) + :lisp2) + +;;; Modules +(define-variable-pattern *modules* :lisp) +(define-caller-pattern provide (form) :lisp) +(define-caller-pattern require (form &optional :ignore) :lisp) + + +;;; Numbers +(define-caller-pattern zerop (form) :lisp) +(define-caller-pattern plusp (form) :lisp) +(define-caller-pattern minusp (form) :lisp) +(define-caller-pattern oddp (form) :lisp) +(define-caller-pattern evenp (form) :lisp) + +(define-caller-pattern = (form (:star form)) :lisp) +(define-caller-pattern /= (form (:star form)) :lisp) +(define-caller-pattern > (form (:star form)) :lisp) +(define-caller-pattern < (form (:star form)) :lisp) +(define-caller-pattern <= (form (:star form)) :lisp) +(define-caller-pattern >= (form (:star form)) :lisp) + +(define-caller-pattern max (form (:star form)) :lisp) +(define-caller-pattern min (form (:star form)) :lisp) + +(define-caller-pattern - (form (:star form)) :lisp) +(define-caller-pattern + (form (:star form)) :lisp) +(define-caller-pattern * (form (:star form)) :lisp) +(define-caller-pattern / (form (:star form)) :lisp) +(define-caller-pattern 1+ (form) :lisp) +(define-caller-pattern 1- (form) :lisp) + +(define-caller-pattern incf (form form) :lisp) +(define-caller-pattern decf (form form) :lisp) + +(define-caller-pattern conjugate (form) :lisp) + +(define-caller-pattern gcd ((:star form)) :lisp) +(define-caller-pattern lcm ((:star form)) :lisp) + +(define-caller-pattern exp (form) :lisp) +(define-caller-pattern expt (form form) :lisp) +(define-caller-pattern log (form (:optional form)) :lisp) +(define-caller-pattern sqrt (form) :lisp) +(define-caller-pattern isqrt (form) :lisp) + +(define-caller-pattern abs (form) :lisp) +(define-caller-pattern phase (form) :lisp) +(define-caller-pattern signum (form) :lisp) +(define-caller-pattern sin (form) :lisp) +(define-caller-pattern cos (form) :lisp) +(define-caller-pattern tan (form) :lisp) +(define-caller-pattern cis (form) :lisp) +(define-caller-pattern asin (form) :lisp) +(define-caller-pattern acos (form) :lisp) +(define-caller-pattern atan (form &optional form) :lisp) +(define-variable-pattern pi :lisp) + +(define-caller-pattern sinh (form) :lisp) +(define-caller-pattern cosh (form) :lisp) +(define-caller-pattern tanh (form) :lisp) +(define-caller-pattern asinh (form) :lisp) +(define-caller-pattern acosh (form) :lisp) +(define-caller-pattern atanh (form) :lisp) + +;;; Type Conversions and Extractions +(define-caller-pattern float (form (:optional form)) :lisp) +(define-caller-pattern rational (form) :lisp) +(define-caller-pattern rationalize (form) :lisp) +(define-caller-pattern numerator (form) :lisp) +(define-caller-pattern denominator (form) :lisp) + +(define-caller-pattern floor (form (:optional form)) :lisp) +(define-caller-pattern ceiling (form (:optional form)) :lisp) +(define-caller-pattern truncate (form (:optional form)) :lisp) +(define-caller-pattern round (form (:optional form)) :lisp) + +(define-caller-pattern mod (form form) :lisp) +(define-caller-pattern rem (form form) :lisp) + +(define-caller-pattern ffloor (form (:optional form)) :lisp) +(define-caller-pattern fceiling (form (:optional form)) :lisp) +(define-caller-pattern ftruncate (form (:optional form)) :lisp) +(define-caller-pattern fround (form (:optional form)) :lisp) + +(define-caller-pattern decode-float (form) :lisp) +(define-caller-pattern scale-float (form form) :lisp) +(define-caller-pattern float-radix (form) :lisp) +(define-caller-pattern float-sign (form (:optional form)) :lisp) +(define-caller-pattern float-digits (form) :lisp) +(define-caller-pattern float-precision (form) :lisp) +(define-caller-pattern integer-decode-float (form) :lisp) + +(define-caller-pattern complex (form (:optional form)) :lisp) +(define-caller-pattern realpart (form) :lisp) +(define-caller-pattern imagpart (form) :lisp) + +(define-caller-pattern logior ((:star form)) :lisp) +(define-caller-pattern logxor ((:star form)) :lisp) +(define-caller-pattern logand ((:star form)) :lisp) +(define-caller-pattern logeqv ((:star form)) :lisp) + +(define-caller-pattern lognand (form form) :lisp) +(define-caller-pattern lognor (form form) :lisp) +(define-caller-pattern logandc1 (form form) :lisp) +(define-caller-pattern logandc2 (form form) :lisp) +(define-caller-pattern logorc1 (form form) :lisp) +(define-caller-pattern logorc2 (form form) :lisp) + +(define-caller-pattern boole (form form form) :lisp) +(define-variable-pattern boole-clr :lisp) +(define-variable-pattern boole-set :lisp) +(define-variable-pattern boole-1 :lisp) +(define-variable-pattern boole-2 :lisp) +(define-variable-pattern boole-c1 :lisp) +(define-variable-pattern boole-c2 :lisp) +(define-variable-pattern boole-and :lisp) +(define-variable-pattern boole-ior :lisp) +(define-variable-pattern boole-xor :lisp) +(define-variable-pattern boole-eqv :lisp) +(define-variable-pattern boole-nand :lisp) +(define-variable-pattern boole-nor :lisp) +(define-variable-pattern boole-andc1 :lisp) +(define-variable-pattern boole-andc2 :lisp) +(define-variable-pattern boole-orc1 :lisp) +(define-variable-pattern boole-orc2 :lisp) + +(define-caller-pattern lognot (form) :lisp) +(define-caller-pattern logtest (form form) :lisp) +(define-caller-pattern logbitp (form form) :lisp) +(define-caller-pattern ash (form form) :lisp) +(define-caller-pattern logcount (form) :lisp) +(define-caller-pattern integer-length (form) :lisp) + +(define-caller-pattern byte (form form) :lisp) +(define-caller-pattern byte-size (form) :lisp) +(define-caller-pattern byte-position (form) :lisp) +(define-caller-pattern ldb (form form) :lisp) +(define-caller-pattern ldb-test (form form) :lisp) +(define-caller-pattern mask-field (form form) :lisp) +(define-caller-pattern dpb (form form form) :lisp) +(define-caller-pattern deposit-field (form form form) :lisp) + +;;; Random Numbers +(define-caller-pattern random (form (:optional form)) :lisp) +(define-variable-pattern *random-state* :lisp) +(define-caller-pattern make-random-state ((:optional form)) :lisp) +(define-caller-pattern random-state-p (form) :lisp) + +;;; Implementation Parameters +(define-variable-pattern most-positive-fixnum :lisp) +(define-variable-pattern most-negative-fixnum :lisp) +(define-variable-pattern most-positive-short-float :lisp) +(define-variable-pattern least-positive-short-float :lisp) +(define-variable-pattern least-negative-short-float :lisp) +(define-variable-pattern most-negative-short-float :lisp) +(define-variable-pattern most-positive-single-float :lisp) +(define-variable-pattern least-positive-single-float :lisp) +(define-variable-pattern least-negative-single-float :lisp) +(define-variable-pattern most-negative-single-float :lisp) +(define-variable-pattern most-positive-double-float :lisp) +(define-variable-pattern least-positive-double-float :lisp) +(define-variable-pattern least-negative-double-float :lisp) +(define-variable-pattern most-negative-double-float :lisp) +(define-variable-pattern most-positive-long-float :lisp) +(define-variable-pattern least-positive-long-float :lisp) +(define-variable-pattern least-negative-long-float :lisp) +(define-variable-pattern most-negative-long-float :lisp) +(define-variable-pattern least-positive-normalized-short-float :lisp2) +(define-variable-pattern least-negative-normalized-short-float :lisp2) +(define-variable-pattern least-positive-normalized-single-float :lisp2) +(define-variable-pattern least-negative-normalized-single-float :lisp2) +(define-variable-pattern least-positive-normalized-double-float :lisp2) +(define-variable-pattern least-negative-normalized-double-float :lisp2) +(define-variable-pattern least-positive-normalized-long-float :lisp2) +(define-variable-pattern least-negative-normalized-long-float :lisp2) +(define-variable-pattern short-float-epsilon :lisp) +(define-variable-pattern single-float-epsilon :lisp) +(define-variable-pattern double-float-epsilon :lisp) +(define-variable-pattern long-float-epsilon :lisp) +(define-variable-pattern short-float-negative-epsilon :lisp) +(define-variable-pattern single-float-negative-epsilon :lisp) +(define-variable-pattern double-float-negative-epsilon :lisp) +(define-variable-pattern long-float-negative-epsilon :lisp) + +;;; Characters +(define-variable-pattern char-code-limit :lisp) +(define-variable-pattern char-font-limit :lisp) +(define-variable-pattern char-bits-limit :lisp) +(define-caller-pattern standard-char-p (form) :lisp) +(define-caller-pattern graphic-char-p (form) :lisp) +(define-caller-pattern string-char-p (form) :lisp) +(define-caller-pattern alpha-char-p (form) :lisp) +(define-caller-pattern upper-case-p (form) :lisp) +(define-caller-pattern lower-case-p (form) :lisp) +(define-caller-pattern both-case-p (form) :lisp) +(define-caller-pattern digit-char-p (form (:optional form)) :lisp) +(define-caller-pattern alphanumericp (form) :lisp) + +(define-caller-pattern char= ((:star form)) :lisp) +(define-caller-pattern char/= ((:star form)) :lisp) +(define-caller-pattern char< ((:star form)) :lisp) +(define-caller-pattern char> ((:star form)) :lisp) +(define-caller-pattern char<= ((:star form)) :lisp) +(define-caller-pattern char>= ((:star form)) :lisp) + +(define-caller-pattern char-equal ((:star form)) :lisp) +(define-caller-pattern char-not-equal ((:star form)) :lisp) +(define-caller-pattern char-lessp ((:star form)) :lisp) +(define-caller-pattern char-greaterp ((:star form)) :lisp) +(define-caller-pattern char-not-greaterp ((:star form)) :lisp) +(define-caller-pattern char-not-lessp ((:star form)) :lisp) + +(define-caller-pattern char-code (form) :lisp) +(define-caller-pattern char-bits (form) :lisp) +(define-caller-pattern char-font (form) :lisp) +(define-caller-pattern code-char (form (:optional form form)) :lisp) +(define-caller-pattern make-char (form (:optional form form)) :lisp) +(define-caller-pattern characterp (form) :lisp) +(define-caller-pattern char-upcase (form) :lisp) +(define-caller-pattern char-downcase (form) :lisp) +(define-caller-pattern digit-char (form (:optional form form)) :lisp) +(define-caller-pattern char-int (form) :lisp) +(define-caller-pattern int-char (form) :lisp) +(define-caller-pattern char-name (form) :lisp) +(define-caller-pattern name-char (form) :lisp) +(define-variable-pattern char-control-bit :lisp) +(define-variable-pattern char-meta-bit :lisp) +(define-variable-pattern char-super-bit :lisp) +(define-variable-pattern char-hyper-bit :lisp) +(define-caller-pattern char-bit (form form) :lisp) +(define-caller-pattern set-char-bit (form form form) :lisp) + +;;; Sequences +(define-caller-pattern complement (fn) :lisp2) +(define-caller-pattern elt (form form) :lisp) +(define-caller-pattern subseq (form form &optional form) :lisp) +(define-caller-pattern copy-seq (form) :lisp) +(define-caller-pattern length (form) :lisp) +(define-caller-pattern reverse (form) :lisp) +(define-caller-pattern nreverse (form) :lisp) +(define-caller-pattern make-sequence (form form &key form) :lisp) + +(define-caller-pattern concatenate (form (:star form)) :lisp) +(define-caller-pattern map (form fn form (:star form)) :lisp) +(define-caller-pattern map-into (form fn (:star form)) :lisp2) + +(define-caller-pattern some (fn form (:star form)) :lisp) +(define-caller-pattern every (fn form (:star form)) :lisp) +(define-caller-pattern notany (fn form (:star form)) :lisp) +(define-caller-pattern notevery (fn form (:star form)) :lisp) + +(define-caller-pattern reduce (fn form &key (:star form)) :lisp) +(define-caller-pattern fill (form form &key (:star form)) :lisp) +(define-caller-pattern replace (form form &key (:star form)) :lisp) +(define-caller-pattern remove (form form &key (:star form)) :lisp) +(define-caller-pattern remove-if (fn form &key (:star form)) :lisp) +(define-caller-pattern remove-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern delete (form form &key (:star form)) :lisp) +(define-caller-pattern delete-if (fn form &key (:star form)) :lisp) +(define-caller-pattern delete-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern remove-duplicates (form &key (:star form)) :lisp) +(define-caller-pattern delete-duplicates (form &key (:star form)) :lisp) +(define-caller-pattern substitute (form form form &key (:star form)) :lisp) +(define-caller-pattern substitute-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern substitute-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute (form form form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern find (form form &key (:star form)) :lisp) +(define-caller-pattern find-if (fn form &key (:star form)) :lisp) +(define-caller-pattern find-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern position (form form &key (:star form)) :lisp) +(define-caller-pattern position-if (fn form &key (:star form)) :lisp) +(define-caller-pattern position-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern count (form form &key (:star form)) :lisp) +(define-caller-pattern count-if (fn form &key (:star form)) :lisp) +(define-caller-pattern count-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern mismatch (form form &key (:star form)) :lisp) +(define-caller-pattern search (form form &key (:star form)) :lisp) +(define-caller-pattern sort (form fn &key (:star form)) :lisp) +(define-caller-pattern stable-sort (form fn &key (:star form)) :lisp) +(define-caller-pattern merge (form form form fn &key (:star form)) :lisp) + +;;; Lists +(define-caller-pattern car (form) :lisp) +(define-caller-pattern cdr (form) :lisp) +(define-caller-pattern caar (form) :lisp) +(define-caller-pattern cadr (form) :lisp) +(define-caller-pattern cdar (form) :lisp) +(define-caller-pattern cddr (form) :lisp) +(define-caller-pattern caaar (form) :lisp) +(define-caller-pattern caadr (form) :lisp) +(define-caller-pattern cadar (form) :lisp) +(define-caller-pattern caddr (form) :lisp) +(define-caller-pattern cdaar (form) :lisp) +(define-caller-pattern cdadr (form) :lisp) +(define-caller-pattern cddar (form) :lisp) +(define-caller-pattern cdddr (form) :lisp) +(define-caller-pattern caaaar (form) :lisp) +(define-caller-pattern caaadr (form) :lisp) +(define-caller-pattern caadar (form) :lisp) +(define-caller-pattern caaddr (form) :lisp) +(define-caller-pattern cadaar (form) :lisp) +(define-caller-pattern cadadr (form) :lisp) +(define-caller-pattern caddar (form) :lisp) +(define-caller-pattern cadddr (form) :lisp) +(define-caller-pattern cdaaar (form) :lisp) +(define-caller-pattern cdaadr (form) :lisp) +(define-caller-pattern cdadar (form) :lisp) +(define-caller-pattern cdaddr (form) :lisp) +(define-caller-pattern cddaar (form) :lisp) +(define-caller-pattern cddadr (form) :lisp) +(define-caller-pattern cdddar (form) :lisp) +(define-caller-pattern cddddr (form) :lisp) + +(define-caller-pattern cons (form form) :lisp) +(define-caller-pattern tree-equal (form form &key (:star fn)) :lisp) +(define-caller-pattern endp (form) :lisp) +(define-caller-pattern list-length (form) :lisp) +(define-caller-pattern nth (form form) :lisp) + +(define-caller-pattern first (form) :lisp) +(define-caller-pattern second (form) :lisp) +(define-caller-pattern third (form) :lisp) +(define-caller-pattern fourth (form) :lisp) +(define-caller-pattern fifth (form) :lisp) +(define-caller-pattern sixth (form) :lisp) +(define-caller-pattern seventh (form) :lisp) +(define-caller-pattern eighth (form) :lisp) +(define-caller-pattern ninth (form) :lisp) +(define-caller-pattern tenth (form) :lisp) + +(define-caller-pattern rest (form) :lisp) +(define-caller-pattern nthcdr (form form) :lisp) +(define-caller-pattern last (form (:optional form)) :lisp) +(define-caller-pattern list ((:star form)) :lisp) +(define-caller-pattern list* ((:star form)) :lisp) +(define-caller-pattern make-list (form &key (:star form)) :lisp) +(define-caller-pattern append ((:star form)) :lisp) +(define-caller-pattern copy-list (form) :lisp) +(define-caller-pattern copy-alist (form) :lisp) +(define-caller-pattern copy-tree (form) :lisp) +(define-caller-pattern revappend (form form) :lisp) +(define-caller-pattern nconc ((:star form)) :lisp) +(define-caller-pattern nreconc (form form) :lisp) +(define-caller-pattern push (form form) :lisp) +(define-caller-pattern pushnew (form form &key (:star form)) :lisp) +(define-caller-pattern pop (form) :lisp) +(define-caller-pattern butlast (form (:optional form)) :lisp) +(define-caller-pattern nbutlast (form (:optional form)) :lisp) +(define-caller-pattern ldiff (form form) :lisp) +(define-caller-pattern rplaca (form form) :lisp) +(define-caller-pattern rplacd (form form) :lisp) + +(define-caller-pattern subst (form form form &key (:star form)) :lisp) +(define-caller-pattern subst-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern subst-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubst (form form form &key (:star form)) :lisp) +(define-caller-pattern nsubst-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubst-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern sublis (form form &key (:star form)) :lisp) +(define-caller-pattern nsublis (form form &key (:star form)) :lisp) +(define-caller-pattern member (form form &key (:star form)) :lisp) +(define-caller-pattern member-if (fn form &key (:star form)) :lisp) +(define-caller-pattern member-if-not (fn form &key (:star form)) :lisp) + +(define-caller-pattern tailp (form form) :lisp) +(define-caller-pattern adjoin (form form &key (:star form)) :lisp) +(define-caller-pattern union (form form &key (:star form)) :lisp) +(define-caller-pattern nunion (form form &key (:star form)) :lisp) +(define-caller-pattern intersection (form form &key (:star form)) :lisp) +(define-caller-pattern nintersection (form form &key (:star form)) :lisp) +(define-caller-pattern set-difference (form form &key (:star form)) :lisp) +(define-caller-pattern nset-difference (form form &key (:star form)) :lisp) +(define-caller-pattern set-exclusive-or (form form &key (:star form)) :lisp) +(define-caller-pattern nset-exclusive-or (form form &key (:star form)) :lisp) +(define-caller-pattern subsetp (form form &key (:star form)) :lisp) + +(define-caller-pattern acons (form form form) :lisp) +(define-caller-pattern pairlis (form form (:optional form)) :lisp) +(define-caller-pattern assoc (form form &key (:star form)) :lisp) +(define-caller-pattern assoc-if (fn form) :lisp) +(define-caller-pattern assoc-if-not (fn form) :lisp) +(define-caller-pattern rassoc (form form &key (:star form)) :lisp) +(define-caller-pattern rassoc-if (fn form &key (:star form)) :lisp) +(define-caller-pattern rassoc-if-not (fn form &key (:star form)) :lisp) + +;;; Hash Tables +(define-caller-pattern make-hash-table (&key (:star form)) :lisp) +(define-caller-pattern hash-table-p (form) :lisp) +(define-caller-pattern gethash (form form (:optional form)) :lisp) +(define-caller-pattern remhash (form form) :lisp) +(define-caller-pattern maphash (fn form) :lisp) +(define-caller-pattern clrhash (form) :lisp) +(define-caller-pattern hash-table-count (form) :lisp) +(define-caller-pattern with-hash-table-iterator + ((name form) (:star form)) :lisp2) +(define-caller-pattern hash-table-rehash-size (form) :lisp2) +(define-caller-pattern hash-table-rehash-threshold (form) :lisp2) +(define-caller-pattern hash-table-size (form) :lisp2) +(define-caller-pattern hash-table-test (form) :lisp2) +(define-caller-pattern sxhash (form) :lisp) + +;;; Arrays +(define-caller-pattern make-array (form &key (:star form)) :lisp) +(define-variable-pattern array-rank-limit :lisp) +(define-variable-pattern array-dimension-limit :lisp) +(define-variable-pattern array-total-size-limit :lisp) +(define-caller-pattern vector ((:star form)) :lisp) +(define-caller-pattern aref (form (:star form)) :lisp) +(define-caller-pattern svref (form form) :lisp) +(define-caller-pattern array-element-type (form) :lisp) +(define-caller-pattern array-rank (form) :lisp) +(define-caller-pattern array-dimension (form form) :lisp) +(define-caller-pattern array-dimensions (form) :lisp) +(define-caller-pattern array-total-size (form) :lisp) +(define-caller-pattern array-in-bounds-p (form (:star form)) :lisp) +(define-caller-pattern array-row-major-index (form (:star form)) :lisp) +(define-caller-pattern row-major-aref (form form) :lisp2) +(define-caller-pattern adjustable-array-p (form) :lisp) + +(define-caller-pattern bit (form (:star form)) :lisp) +(define-caller-pattern sbit (form (:star form)) :lisp) + +(define-caller-pattern bit-and (form form (:optional form)) :lisp) +(define-caller-pattern bit-ior (form form (:optional form)) :lisp) +(define-caller-pattern bit-xor (form form (:optional form)) :lisp) +(define-caller-pattern bit-eqv (form form (:optional form)) :lisp) +(define-caller-pattern bit-nand (form form (:optional form)) :lisp) +(define-caller-pattern bit-nor (form form (:optional form)) :lisp) +(define-caller-pattern bit-andc1 (form form (:optional form)) :lisp) +(define-caller-pattern bit-andc2 (form form (:optional form)) :lisp) +(define-caller-pattern bit-orc1 (form form (:optional form)) :lisp) +(define-caller-pattern bit-orc2 (form form (:optional form)) :lisp) +(define-caller-pattern bit-not (form (:optional form)) :lisp) + +(define-caller-pattern array-has-fill-pointer-p (form) :lisp) +(define-caller-pattern fill-pointer (form) :lisp) +(define-caller-pattern vector-push (form form) :lisp) +(define-caller-pattern vector-push-extend (form form (:optional form)) :lisp) +(define-caller-pattern vector-pop (form) :lisp) +(define-caller-pattern adjust-array (form form &key (:star form)) :lisp) + +;;; Strings +(define-caller-pattern char (form form) :lisp) +(define-caller-pattern schar (form form) :lisp) +(define-caller-pattern string= (form form &key (:star form)) :lisp) +(define-caller-pattern string-equal (form form &key (:star form)) :lisp) +(define-caller-pattern string< (form form &key (:star form)) :lisp) +(define-caller-pattern string> (form form &key (:star form)) :lisp) +(define-caller-pattern string<= (form form &key (:star form)) :lisp) +(define-caller-pattern string>= (form form &key (:star form)) :lisp) +(define-caller-pattern string/= (form form &key (:star form)) :lisp) +(define-caller-pattern string-lessp (form form &key (:star form)) :lisp) +(define-caller-pattern string-greaterp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-greaterp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-lessp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-equal (form form &key (:star form)) :lisp) + +(define-caller-pattern make-string (form &key (:star form)) :lisp) +(define-caller-pattern string-trim (form form) :lisp) +(define-caller-pattern string-left-trim (form form) :lisp) +(define-caller-pattern string-right-trim (form form) :lisp) +(define-caller-pattern string-upcase (form &key (:star form)) :lisp) +(define-caller-pattern string-downcase (form &key (:star form)) :lisp) +(define-caller-pattern string-capitalize (form &key (:star form)) :lisp) +(define-caller-pattern nstring-upcase (form &key (:star form)) :lisp) +(define-caller-pattern nstring-downcase (form &key (:star form)) :lisp) +(define-caller-pattern nstring-capitalize (form &key (:star form)) :lisp) +(define-caller-pattern string (form) :lisp) + +;;; Structures +(define-caller-pattern defstruct + ((:or name (name (:rest :ignore))) + (:optional documentation-string) + (:plus :ignore)) + :lisp) + +;;; The Evaluator +(define-caller-pattern eval (form) :lisp) +(define-variable-pattern *evalhook* :lisp) +(define-variable-pattern *applyhook* :lisp) +(define-caller-pattern evalhook (form fn fn &optional :ignore) :lisp) +(define-caller-pattern applyhook (fn form fn fn &optional :ignore) :lisp) +(define-caller-pattern constantp (form) :lisp) + +;;; Streams +(define-variable-pattern *standard-input* :lisp) +(define-variable-pattern *standard-output* :lisp) +(define-variable-pattern *error-output* :lisp) +(define-variable-pattern *query-io* :lisp) +(define-variable-pattern *debug-io* :lisp) +(define-variable-pattern *terminal-io* :lisp) +(define-variable-pattern *trace-output* :lisp) +(define-caller-pattern make-synonym-stream (symbol) :lisp) +(define-caller-pattern make-broadcast-stream ((:star form)) :lisp) +(define-caller-pattern make-concatenated-stream ((:star form)) :lisp) +(define-caller-pattern make-two-way-stream (form form) :lisp) +(define-caller-pattern make-echo-stream (form form) :lisp) +(define-caller-pattern make-string-input-stream (form &optional form form) :lisp) +(define-caller-pattern make-string-output-stream (&key (:star form)) :lisp) +(define-caller-pattern get-output-stream-string (form) :lisp) + +(define-caller-pattern with-open-stream + ((var form) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern with-input-from-string + ((var form &key (:star form)) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern with-output-to-string + ((var (:optional form)) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern streamp (form) :lisp) +(define-caller-pattern open-stream-p (form) :lisp2) +(define-caller-pattern input-stream-p (form) :lisp) +(define-caller-pattern output-stream-p (form) :lisp) +(define-caller-pattern stream-element-type (form) :lisp) +(define-caller-pattern close (form (:rest :ignore)) :lisp) +(define-caller-pattern broadcast-stream-streams (form) :lisp2) +(define-caller-pattern concatenated-stream-streams (form) :lisp2) +(define-caller-pattern echo-stream-input-stream (form) :lisp2) +(define-caller-pattern echo-stream-output-stream (form) :lisp2) +(define-caller-pattern synonym-stream-symbol (form) :lisp2) +(define-caller-pattern two-way-stream-input-stream (form) :lisp2) +(define-caller-pattern two-way-stream-output-stream (form) :lisp2) +(define-caller-pattern interactive-stream-p (form) :lisp2) +(define-caller-pattern stream-external-format (form) :lisp2) + +;;; Reader +(define-variable-pattern *read-base* :lisp) +(define-variable-pattern *read-suppress* :lisp) +(define-variable-pattern *read-eval* :lisp2) +(define-variable-pattern *readtable* :lisp) +(define-caller-pattern copy-readtable (&optional form form) :lisp) +(define-caller-pattern readtablep (form) :lisp) +(define-caller-pattern set-syntax-from-char (form form &optional form form) :lisp) +(define-caller-pattern set-macro-character (form fn &optional form) :lisp) +(define-caller-pattern get-macro-character (form (:optional form)) :lisp) +(define-caller-pattern make-dispatch-macro-character (form &optional form form) + :lisp) +(define-caller-pattern set-dispatch-macro-character + (form form fn (:optional form)) :lisp) +(define-caller-pattern get-dispatch-macro-character + (form form (:optional form)) :lisp) +(define-caller-pattern readtable-case (form) :lisp2) +(define-variable-pattern *print-readably* :lisp2) +(define-variable-pattern *print-escape* :lisp) +(define-variable-pattern *print-pretty* :lisp) +(define-variable-pattern *print-circle* :lisp) +(define-variable-pattern *print-base* :lisp) +(define-variable-pattern *print-radix* :lisp) +(define-variable-pattern *print-case* :lisp) +(define-variable-pattern *print-gensym* :lisp) +(define-variable-pattern *print-level* :lisp) +(define-variable-pattern *print-length* :lisp) +(define-variable-pattern *print-array* :lisp) +(define-caller-pattern with-standard-io-syntax + ((:star declaration) + (:star form)) + :lisp2) + +(define-caller-pattern read (&optional form form form form) :lisp) +(define-variable-pattern *read-default-float-format* :lisp) +(define-caller-pattern read-preserving-whitespace + (&optional form form form form) :lisp) +(define-caller-pattern read-delimited-list (form &optional form form) :lisp) +(define-caller-pattern read-line (&optional form form form form) :lisp) +(define-caller-pattern read-char (&optional form form form form) :lisp) +(define-caller-pattern unread-char (form (:optional form)) :lisp) +(define-caller-pattern peek-char (&optional form form form form) :lisp) +(define-caller-pattern listen ((:optional form)) :lisp) +(define-caller-pattern read-char-no-hang ((:star form)) :lisp) +(define-caller-pattern clear-input ((:optional form)) :lisp) +(define-caller-pattern read-from-string (form (:star form)) :lisp) +(define-caller-pattern parse-integer (form &rest :ignore) :lisp) +(define-caller-pattern read-byte ((:star form)) :lisp) + +(define-caller-pattern write (form &key (:star form)) :lisp) +(define-caller-pattern prin1 (form (:optional form)) :lisp) +(define-caller-pattern print (form (:optional form)) :lisp) +(define-caller-pattern pprint (form (:optional form)) :lisp) +(define-caller-pattern princ (form (:optional form)) :lisp) +(define-caller-pattern write-to-string (form &key (:star form)) :lisp) +(define-caller-pattern prin1-to-string (form) :lisp) +(define-caller-pattern princ-to-string (form) :lisp) +(define-caller-pattern write-char (form (:optional form)) :lisp) +(define-caller-pattern write-string (form &optional form &key (:star form)) :lisp) +(define-caller-pattern write-line (form &optional form &key (:star form)) :lisp) +(define-caller-pattern terpri ((:optional form)) :lisp) +(define-caller-pattern fresh-line ((:optional form)) :lisp) +(define-caller-pattern finish-output ((:optional form)) :lisp) +(define-caller-pattern force-output ((:optional form)) :lisp) +(define-caller-pattern clear-output ((:optional form)) :lisp) +(define-caller-pattern print-unreadable-object + ((form form &key (:star form)) + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern write-byte (form form) :lisp) +(define-caller-pattern format + (destination + control-string + (:rest format-arguments)) + :lisp) + +(define-caller-pattern y-or-n-p (control-string (:star form)) :lisp) +(define-caller-pattern yes-or-no-p (control-string (:star form)) :lisp) + +;;; Pathnames +(define-caller-pattern wild-pathname-p (form &optional form) :lisp2) +(define-caller-pattern pathname-match-p (form form) :lisp2) +(define-caller-pattern translate-pathname (form form form &key (:star form)) + :lisp2) + +(define-caller-pattern logical-pathname (form) :lisp2) +(define-caller-pattern translate-logical-pathname (form &key (:star form)) :lisp2) +(define-caller-pattern logical-pathname-translations (form) :lisp2) +(define-caller-pattern load-logical-pathname-translations (form) :lisp2) +(define-caller-pattern compile-file-pathname (form &key form) :lisp2) + +(define-caller-pattern pathname (form) :lisp) +(define-caller-pattern truename (form) :lisp) +(define-caller-pattern parse-namestring ((:star form)) :lisp) +(define-caller-pattern merge-pathnames ((:star form)) :lisp) +(define-variable-pattern *default-pathname-defaults* :lisp) +(define-caller-pattern make-pathname ((:star form)) :lisp) +(define-caller-pattern pathnamep (form) :lisp) +(define-caller-pattern pathname-host (form) :lisp) +(define-caller-pattern pathname-device (form) :lisp) +(define-caller-pattern pathname-directory (form) :lisp) +(define-caller-pattern pathname-name (form) :lisp) +(define-caller-pattern pathname-type (form) :lisp) +(define-caller-pattern pathname-version (form) :lisp) +(define-caller-pattern namestring (form) :lisp) +(define-caller-pattern file-namestring (form) :lisp) +(define-caller-pattern directory-namestring (form) :lisp) +(define-caller-pattern host-namestring (form) :lisp) +(define-caller-pattern enough-namestring (form (:optional form)) :lisp) +(define-caller-pattern user-homedir-pathname (&optional form) :lisp) +(define-caller-pattern open (form &key (:star form)) :lisp) +(define-caller-pattern with-open-file + ((var form (:rest :ignore)) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern rename-file (form form) :lisp) +(define-caller-pattern delete-file (form) :lisp) +(define-caller-pattern probe-file (form) :lisp) +(define-caller-pattern file-write-date (form) :lisp) +(define-caller-pattern file-author (form) :lisp) +(define-caller-pattern file-position (form (:optional form)) :lisp) +(define-caller-pattern file-length (form) :lisp) +(define-caller-pattern file-string-length (form form) :lisp2) +(define-caller-pattern load (form &key (:star form)) :lisp) +(define-variable-pattern *load-verbose* :lisp) +(define-variable-pattern *load-print* :lisp2) +(define-variable-pattern *load-pathname* :lisp2) +(define-variable-pattern *load-truename* :lisp2) +(define-caller-pattern make-load-form (form) :lisp2) +(define-caller-pattern make-load-form-saving-slots (form &optional form) + :lisp2) +(define-caller-pattern directory (form &key (:star form)) :lisp) + +;;; Errors +(define-caller-pattern error (form (:star form)) :lisp) +(define-caller-pattern cerror (form form (:star form)) :lisp) +(define-caller-pattern warn (form (:star form)) :lisp) +(define-variable-pattern *break-on-warnings* :lisp) +(define-caller-pattern break (&optional form (:star form)) :lisp) +(define-caller-pattern check-type (form form (:optional form)) :lisp) +(define-caller-pattern assert + (form + (:optional ((:star var)) + (:optional form (:star form)))) + :lisp) +(define-caller-pattern etypecase (form (:star (symbol (:star form)))) :lisp) +(define-caller-pattern ctypecase (form (:star (symbol (:star form)))) :lisp) +(define-caller-pattern ecase + (form + (:star ((:or symbol ((:star symbol))) + (:star form)))) + :lisp) +(define-caller-pattern ccase + (form + (:star ((:or symbol ((:star symbol))) + (:star form)))) + :lisp) + +;;; The Compiler +(define-caller-pattern compile (form (:optional form)) :lisp) +(define-caller-pattern compile-file (form &key (:star form)) :lisp) +(define-variable-pattern *compile-verbose* :lisp2) +(define-variable-pattern *compile-print* :lisp2) +(define-variable-pattern *compile-file-pathname* :lisp2) +(define-variable-pattern *compile-file-truename* :lisp2) +(define-caller-pattern load-time-value (form (:optional form)) :lisp2) +(define-caller-pattern disassemble (form) :lisp) +(define-caller-pattern function-lambda-expression (fn) :lisp2) +(define-caller-pattern with-compilation-unit (((:star :ignore)) (:star form)) + :lisp2) + +;;; Documentation +(define-caller-pattern documentation (form form) :lisp) +(define-caller-pattern trace ((:star form)) :lisp) +(define-caller-pattern untrace ((:star form)) :lisp) +(define-caller-pattern step (form) :lisp) +(define-caller-pattern time (form) :lisp) +(define-caller-pattern describe (form &optional form) :lisp) +(define-caller-pattern describe-object (form &optional form) :lisp2) +(define-caller-pattern inspect (form) :lisp) +(define-caller-pattern room ((:optional form)) :lisp) +(define-caller-pattern ed ((:optional form)) :lisp) +(define-caller-pattern dribble ((:optional form)) :lisp) +(define-caller-pattern apropos (form (:optional form)) :lisp) +(define-caller-pattern apropos-list (form (:optional form)) :lisp) +(define-caller-pattern get-decoded-time () :lisp) +(define-caller-pattern get-universal-time () :lisp) +(define-caller-pattern decode-universal-time (form &optional form) :lisp) +(define-caller-pattern encode-universal-time + (form form form form form form &optional form) :lisp) +(define-caller-pattern get-internal-run-time () :lisp) +(define-caller-pattern get-internal-real-time () :lisp) +(define-caller-pattern sleep (form) :lisp) + +(define-caller-pattern lisp-implementation-type () :lisp) +(define-caller-pattern lisp-implementation-version () :lisp) +(define-caller-pattern machine-type () :lisp) +(define-caller-pattern machine-version () :lisp) +(define-caller-pattern machine-instance () :lisp) +(define-caller-pattern software-type () :lisp) +(define-caller-pattern software-version () :lisp) +(define-caller-pattern short-site-name () :lisp) +(define-caller-pattern long-site-name () :lisp) +(define-variable-pattern *features* :lisp) + +(define-caller-pattern identity (form) :lisp) + +;;; Pretty Printing +(define-variable-pattern *print-pprint-dispatch* :lisp2) +(define-variable-pattern *print-right-margin* :lisp2) +(define-variable-pattern *print-miser-width* :lisp2) +(define-variable-pattern *print-lines* :lisp2) +(define-caller-pattern pprint-newline (form &optional form) :lisp2) +(define-caller-pattern pprint-logical-block + ((var form &key (:star form)) + (:star form)) + :lisp2) +(define-caller-pattern pprint-exit-if-list-exhausted () :lisp2) +(define-caller-pattern pprint-pop () :lisp2) +(define-caller-pattern pprint-indent (form form &optional form) :lisp2) +(define-caller-pattern pprint-tab (form form form &optional form) :lisp2) +(define-caller-pattern pprint-fill (form form &optional form form) :lisp2) +(define-caller-pattern pprint-linear (form form &optional form form) :lisp2) +(define-caller-pattern pprint-tabular (form form &optional form form form) :lisp2) +(define-caller-pattern formatter (control-string) :lisp2) +(define-caller-pattern copy-pprint-dispatch (&optional form) :lisp2) +(define-caller-pattern pprint-dispatch (form &optional form) :lisp2) +(define-caller-pattern set-pprint-dispatch (form form &optional form form) + :lisp2) + +;;; CLOS +(define-caller-pattern add-method (fn form) :lisp2) +(define-caller-pattern call-method (form form) :lisp2) +(define-caller-pattern call-next-method ((:star form)) :lisp2) +(define-caller-pattern change-class (form form) :lisp2) +(define-caller-pattern class-name (form) :lisp2) +(define-caller-pattern class-of (form) :lisp2) +(define-caller-pattern compute-applicable-methods (fn (:star form)) :lisp2) +(define-caller-pattern defclass (name &rest :ignore) :lisp2) +(define-caller-pattern defgeneric (name lambda-list &rest :ignore) :lisp2) +(define-caller-pattern define-method-combination + (name lambda-list ((:star :ignore)) + (:optional ((:eq :arguments) :ignore)) + (:optional ((:eq :generic-function) :ignore)) + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern defmethod + (name (:star symbol) lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern ensure-generic-function (name &key (:star form)) :lisp2) +(define-caller-pattern find-class (form &optional form form) :lisp2) +(define-caller-pattern find-method (fn &rest :ignore) :lisp2) +(define-caller-pattern function-keywords (&rest :ignore) :lisp2) +(define-caller-pattern generic-flet (((:star (name lambda-list))) (:star form)) + :lisp2) +(define-caller-pattern generic-labels + (((:star (name lambda-list))) (:star form)) + :lisp2) +(define-caller-pattern generic-function (lambda-list) :lisp2) +(define-caller-pattern initialize-instance (form &key (:star form)) :lisp2) +(define-caller-pattern invalid-method-error (fn form (:star form)) :lisp2) +(define-caller-pattern make-instance (fn (:star form)) :lisp2) +(define-caller-pattern make-instances-obsolete (fn) :lisp2) +(define-caller-pattern method-combination-error (form (:star form)) :lisp2) +(define-caller-pattern method-qualifiers (fn) :lisp2) +(define-caller-pattern next-method-p () :lisp2) +(define-caller-pattern no-applicable-method (fn (:star form)) :lisp2) +(define-caller-pattern no-next-method (fn (:star form)) :lisp2) +(define-caller-pattern print-object (form form) :lisp2) +(define-caller-pattern reinitialize-instance (form (:star form)) :lisp2) +(define-caller-pattern remove-method (fn form) :lisp2) +(define-caller-pattern shared-initialize (form form (:star form)) :lisp2) +(define-caller-pattern slot-boundp (form form) :lisp2) +(define-caller-pattern slot-exists-p (form form) :lisp2) +(define-caller-pattern slot-makeunbound (form form) :lisp2) +(define-caller-pattern slot-missing (fn form form form &optional form) :lisp2) +(define-caller-pattern slot-unbound (fn form form) :lisp2) +(define-caller-pattern slot-value (form form) :lisp2) +(define-caller-pattern update-instance-for-different-class + (form form (:star form)) :lisp2) +(define-caller-pattern update-instance-for-redefined-class + (form form (:star form)) :lisp2) +(define-caller-pattern with-accessors + (((:star :ignore)) form + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern with-added-methods + ((name lambda-list) form + (:star form)) + :lisp2) +(define-caller-pattern with-slots + (((:star :ignore)) form + (:star declaration) + (:star form)) + :lisp2) + +;;; Conditions +(define-caller-pattern signal (form (:star form)) :lisp2) +(define-variable-pattern *break-on-signals* :lisp2) +(define-caller-pattern handler-case (form (:star (form ((:optional var)) + (:star form)))) + :lisp2) +(define-caller-pattern ignore-errors ((:star form)) :lisp2) +(define-caller-pattern handler-bind (((:star (form form))) + (:star form)) + :lisp2) +(define-caller-pattern define-condition (name &rest :ignore) :lisp2) +(define-caller-pattern make-condition (form &rest :ignore) :lisp2) +(define-caller-pattern with-simple-restart + ((name form (:star form)) (:star form)) :lisp2) +(define-caller-pattern restart-case + (form + (:star (form form (:star form)))) + :lisp2) +(define-caller-pattern restart-bind + (((:star (name fn &key (:star form)))) + (:star form)) + :lisp2) +(define-caller-pattern with-condition-restarts + (form form + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern compute-restarts (&optional form) :lisp2) +(define-caller-pattern restart-name (form) :lisp2) +(define-caller-pattern find-restart (form &optional form) :lisp2) +(define-caller-pattern invoke-restart (form (:star form)) :lisp2) +(define-caller-pattern invoke-restart-interactively (form) :lisp2) +(define-caller-pattern abort (&optional form) :lisp2) +(define-caller-pattern continue (&optional form) :lisp2) +(define-caller-pattern muffle-warning (&optional form) :lisp2) +(define-caller-pattern store-value (form &optional form) :lisp2) +(define-caller-pattern use-value (form &optional form) :lisp2) +(define-caller-pattern invoke-debugger (form) :lisp2) +(define-variable-pattern *debugger-hook* :lisp2) +(define-caller-pattern simple-condition-format-string (form) :lisp2) +(define-caller-pattern simple-condition-format-arguments (form) :lisp2) +(define-caller-pattern type-error-datum (form) :lisp2) +(define-caller-pattern type-error-expected-type (form) :lisp2) +(define-caller-pattern package-error-package (form) :lisp2) +(define-caller-pattern stream-error-stream (form) :lisp2) +(define-caller-pattern file-error-pathname (form) :lisp2) +(define-caller-pattern cell-error-name (form) :lisp2) +(define-caller-pattern arithmetic-error-operation (form) :lisp2) +(define-caller-pattern arithmetic-error-operands (form) :lisp2) + +;;; For ZetaLisp Flavors +(define-caller-pattern send (form fn (:star form)) :flavors)

1 0

[bknr-cvs] r2199 - branches/trunk-reorg/thirdparty
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 13:22:27 -0400 (Thu, 04 Oct 2007) New Revision: 2199 Removed: branches/trunk-reorg/thirdparty/slime/ Log: slime updating

1 0

[bknr-cvs] r2198 - in branches/trunk-reorg: . bknr
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 13:15:52 -0400 (Thu, 04 Oct 2007) New Revision: 2198 Added: branches/trunk-reorg/bknr/web/ Removed: branches/trunk-reorg/web/ Log: checkpoint Copied: branches/trunk-reorg/bknr/web (from rev 2190, branches/trunk-reorg/web)

1 0

[bknr-cvs] r2197 - in branches/trunk-reorg: . bknr
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 13:15:19 -0400 (Thu, 04 Oct 2007) New Revision: 2197 Added: branches/trunk-reorg/bknr/tools/ Removed: branches/trunk-reorg/tools/ Log: checkpoint Copied: branches/trunk-reorg/bknr/tools (from rev 2190, branches/trunk-reorg/tools)

1 0

[bknr-cvs] r2196 - in branches/trunk-reorg: . bknr
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 13:14:53 -0400 (Thu, 04 Oct 2007) New Revision: 2196 Added: branches/trunk-reorg/bknr/LICENSE Removed: branches/trunk-reorg/LICENSE Log: checkpoint Deleted: branches/trunk-reorg/LICENSE =================================================================== --- branches/trunk-reorg/LICENSE 2007-10-04 17:13:34 UTC (rev 2195) +++ branches/trunk-reorg/LICENSE 2007-10-04 17:14:53 UTC (rev 2196) @@ -1,30 +0,0 @@ -Copyright (c) 2003,2004,2005, BKNR (Hans H�bner, Manuel Odendahl) -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - - Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - - Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - - - Neither the name BKNR nor the names of its contributors may be - used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Copied: branches/trunk-reorg/bknr/LICENSE (from rev 2190, branches/trunk-reorg/LICENSE)

1 0

[bknr-cvs] r2195 - in branches/trunk-reorg: . bknr
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 13:13:34 -0400 (Thu, 04 Oct 2007) New Revision: 2195 Added: branches/trunk-reorg/bknr/projects/ Removed: branches/trunk-reorg/projects/ Log: checkpoint Copied: branches/trunk-reorg/bknr/projects (from rev 2190, branches/trunk-reorg/projects)

1 0

[bknr-cvs] r2194 - in branches/trunk-reorg: . bknr
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 13:11:30 -0400 (Thu, 04 Oct 2007) New Revision: 2194 Added: branches/trunk-reorg/bknr/modules/ Removed: branches/trunk-reorg/modules/ Log: checkpoint Copied: branches/trunk-reorg/bknr/modules (from rev 2190, branches/trunk-reorg/modules)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs October 2007