chore(3p/lisp): import npg source tarball r/2812

Used http://wcp.sdf-eu.org/software/npg-20150517T144652.tbz (sha256
42e88f6067128fbdb3a3d578371c9b0ee2a34f1d36daf80be8a520094132d828).
There's no upstream repository nor a release since 2015, so importing
seems to make a lot of sense.

Since we can't subtree making any depot-related changes in a separate CL
-- this is only the source import.

Change-Id: I64c984ca0a84b9e48c6f496577ffccce1d7bdceb
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3377
Tested-by: BuildkiteCI
Reviewed-by: grfn <grfn@gws.fyi>

10 files changed, 3609 insertions, 0 deletions

diff --git a/third_party/lisp/npg/.project b/third_party/lisp/npg/.project
new file mode 100644
index 0000000000..82a8fe48bb
--- /dev/null
+++ b/third_party/lisp/npg/.project
@@ -0,0 +1 @@
+NPG a Naive Parser Generator
diff --git a/third_party/lisp/npg/COPYING b/third_party/lisp/npg/COPYING
new file mode 100644
index 0000000000..223ede7de3
--- /dev/null
+++ b/third_party/lisp/npg/COPYING
@@ -0,0 +1,504 @@
+		  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
+
+           How to Apply These Terms to Your New Libraries
+
+  If you develop a new library, and you want it to be of the greatest
+possible use to the public, we recommend making it free software that
+everyone can redistribute and change.  You can do so by permitting
+redistribution under these terms (or, alternatively, under the terms of the
+ordinary General Public License).
+
+  To apply these terms, attach the following notices to the library.  It is
+safest to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the library's name and a brief idea of what it does.>
+    Copyright (C) <year>  <name of author>
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2 of the License, or (at your option) any later version.
+
+    This library is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+Also add information on how to contact you by electronic and paper mail.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the library, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the
+  library `Frob' (a library for tweaking knobs) written by James Random Hacker.
+
+  <signature of Ty Coon>, 1 April 1990
+  Ty Coon, President of Vice
+
+That's all there is to it!
+
+
diff --git a/third_party/lisp/npg/README b/third_party/lisp/npg/README
new file mode 100644
index 0000000000..c69ef9080a
--- /dev/null
+++ b/third_party/lisp/npg/README
@@ -0,0 +1,41 @@
+
+		     NPG a Naive Parser Generator
+			   for Common Lisp
+
+	 Copyright (C) 2003-2006, 2010 by Walter C. Pelissero
+
+This library is  free software; you can redistribute  it and/or modify
+it  under  the terms  of  the GNU  Lesser  General  Public License  as
+published by the  Free Software Foundation; either version  2.1 of the
+License,  or (at  your option)  any  later version.   This library  is
+distributed  in the  hope  that it  will  be useful,  but WITHOUT  ANY
+WARRANTY;  without even  the  implied warranty  of MERCHANTABILITY  or
+FITNESS FOR A  PARTICULAR PURPOSE.  See the GNU  Lesser General Public
+License for more details.  You should  have received a copy of the GNU
+Lesser General Public  License along with this library;  if not, write
+to the  Free Software  Foundation, Inc., 59  Temple Place,  Suite 330,
+Boston, MA 02111-1307 USA
+
+
+This library generates on the fly (no external representation of the
+parser is produced) a recursive descent parser based on the grammar
+rules you have fed it with.  The parser object can then be used to
+scan tokenised input.  Although a facility to produce a lexical
+analiser is not provided, to write such a library is fairly easy for
+most languages.  NPG parsers require your lexer to adhere to a certain
+protocol to be able to communicate with them.  Examples are provided
+that explain these requirements.
+
+While quite possibly not producing the fastest parsers in town, it's
+fairly simple and hopefully easy to debug.  It accepts a lispy EBNF
+grammar description of arbitrary complexity with the exception of
+mutually left recursive rules (watch out, they produce undetected
+infinite recursion) and produces a backtracking recursive descent
+parser.  Immediate left recursive rules are properly simplified,
+though.
+
+Multiple concurrent parsers are supported.
+
+To compile, an ASDF file is provided.
+
+See the examples directory for clues on how to use it.
diff --git a/third_party/lisp/npg/examples/python.lisp b/third_party/lisp/npg/examples/python.lisp
new file mode 100644
index 0000000000..68d794ddec
--- /dev/null
+++ b/third_party/lisp/npg/examples/python.lisp
@@ -0,0 +1,336 @@
+;;;  python.lisp --- sample grammar definition for the Python language
+
+;;;  Copyright (C) 2003 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+;;;  $Id: F-C1A8CD5961889C584B22F05E8B956006.lisp,v 1.3 2004/03/09 10:33:06 wcp Exp $
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+;;;  Commentary:
+;;;
+;;; This is far from being a complete Python grammar.  Actually I
+;;; haven't even read a Python book before starting to write this
+;;; stuff, so the code below comes mostly from wild guessing while
+;;; reading a Python source file.
+;;;
+;;; It's a design decision to avoid writing any transformation in this
+;;; module; only tagging is done at this level.  This improves the
+;;; separation between parsing and transformation, making the grammar
+;;; reusable for other purposes.
+
+
+#+cmu (ext:file-comment "$Id: F-C1A8CD5961889C584B22F05E8B956006.lisp,v 1.3 2004/03/09 10:33:06 wcp Exp $")
+
+(in-package :grammar)
+
+(deflazy define-grammar
+  (let ((*package* #.*package*)
+	(*compile-print* (and parser::*debug* t)))
+    (reset-grammar)
+    (format t "~&creating Python grammar...~%")
+    (populate-grammar)
+    (let ((grammar (parser:generate-grammar)))
+      (reset-grammar)
+      (parser:print-grammar-figures grammar)
+      grammar)))
+
+(defun populate-grammar ()
+
+(defrule program
+    := comment-string? statement+)
+
+(defrule comment-string
+    := string eol
+    :reduce string)
+
+;;; BOB = Beginning Of Block, EOB = End Of Block.  It's lexical
+;;; analyzer's task to find out where a statement or block starts/ends.
+
+(defrule suite
+    := statement-list eol
+    :reduce statement-list
+    := statement-block)
+
+(defrule commentable-suite
+    := statement-list eol
+    :reduce statement-list
+    := commented-statement-block)
+
+(defrule statement-block
+    := bob statement+ eob
+    :reduce $2)
+
+(defrule commented-statement-block
+    := bob comment-string? statement* eob
+    :reduce (cons comment-string statement))
+
+(defrule statement-list
+    := (+ simple-statement ";")
+    :reduce (if (cdr $1)
+		(cons :statement-list $1)
+		(car $1)))
+
+(defrule statement
+    := statement-list eol
+    :reduce statement-list
+    := compound-statement)
+
+(defrule simple-statement
+    := import-statement
+    := raise-statement
+    := assignment
+    := function-call
+    := return-statement
+    := assert-statement
+    := pass-statement
+    := break-statement
+    := continue-statement)
+
+(defrule compound-statement
+    := class-definition
+    := method-definition
+    := try-statement
+    := if-statement
+    := while-statement
+    := for-statement)
+
+(defrule import-statement
+    := "import" (+ package-name ",")
+    :tag :import
+    := "from" package-name "import" (+ symbol-name ",")
+    :tag :import-from)
+
+(defrule package-name := identifier)
+
+(defrule symbol-name
+    := identifier
+    := "*")
+
+(defrule try-statement
+    := "try" ":" suite try-except-part* try-finally-part?
+    :tag :try)
+
+(defrule try-except-part
+    := "except" exception-subject? ":" suite)
+
+(defrule try-finally-part
+    := "finally" ":" suite)
+
+(defrule exception-subject
+    := exception-name exception-variable?)
+
+(defrule exception-variable
+    := "," identifier)
+
+(defrule exception-name := class-name)
+
+(defrule class-name := identifier)
+
+(defrule raise-statement
+    := "raise"
+    :tag :raise-same
+    := "raise" exception-name
+    :tag :raise
+    := "raise" exception-name "," expression
+    :tag :raise
+    := "raise" exception-name "(" expression ")"
+    :tag :raise)
+
+(defrule assignment
+    := (+ variable-with-optional-subscript ",") "=" more-assignment
+    :tag :set)
+
+(defrule more-assignment
+    := expression
+    := assignment)
+
+(defrule variable-with-optional-subscript
+    := variable-name subscript
+    :tag :subscript
+    := variable-name)
+
+(defrule variable-name
+    := (+ identifier ".")
+    :tag :varef)
+
+(defrule expression
+    := expression "or" expression1
+    :tag :or
+    := expression1)
+
+(defrule expression1
+    := expression1 "and" expression2
+    :tag :and
+    := expression2)
+
+(defrule expression2
+    := expression2 "==" expression3
+    :tag :equal
+    := expression2 ">=" expression3
+    :tag :more-equal
+    := expression2 "<=" expression3
+    :tag :less-equal
+    := expression2 "!=" expression3
+    :tag :not-equal
+    := expression2 ">" expression3
+    :tag :more
+    := expression2 "<" expression3
+    :tag :less
+    := expression2 "is" expression3
+    :tag :equal
+    := expression2 "is" "not" expression3
+    :tag :not-equal
+    := expression3)
+
+(defrule expression3
+    := expression3 "+" expression4
+    :tag :plus
+    := expression3 "-" expression4
+    :tag :minus
+    := expression3 "|" expression4
+    :tag :bit-or
+    := expression4)
+
+;; high priority expression
+(defrule expression4
+    := expression4 "*" expression5
+    :tag :mult
+    := expression4 "/" expression5
+    :tag :div
+    := expression4 "%" expression5
+    :tag :modulo
+    := expression4 "&" expression5
+    :tag :bit-and
+    := expression4 "in" expression5
+    :tag :in
+    := expression5)
+
+(defrule expression5
+    := "~" expression5
+    :tag :bit-not
+    := "not" expression5
+    :tag :not
+    := "(" expression ")"
+    := expression6)
+
+(defrule expression6
+    := simple-expression subscript
+    :tag :subscript
+    := simple-expression)
+
+(defrule simple-expression
+    := function-call
+    := variable-name
+    := constant
+    := string-conversion
+    := list-constructor)
+
+(defrule subscript
+    := "[" expression "]"
+    := "[" expression ":" expression "]"
+    := "[" expression ":" "]"
+    :reduce (list expression nil)
+    := "[" ":" expression "]"
+    :reduce (list nil expression))
+
+(defrule string-conversion
+    := "`" expression "`"
+    :tag :to-string)
+
+(defrule constant
+    := number
+    := string
+    := lambda-expression)
+
+(defrule number
+    := float
+    := integer)
+
+(defrule list-constructor
+    := "[" (* expression ",") "]"
+    :tag :make-list)
+
+(defrule class-definition
+    := "class" class-name superclasses? ":" commentable-suite
+    :tag :defclass)
+
+(defrule superclasses
+    := "(" class-name+ ")")
+
+(defrule method-definition
+    := "def" method-name "(" method-arguments ")" ":" commentable-suite
+    :tag :defmethod)
+
+(defrule method-arguments
+    := (* method-argument ","))
+
+(defrule method-argument
+    := identifier argument-default?)
+
+(defrule argument-default
+    := "=" expression)
+
+(defrule method-name := identifier)
+
+(defrule if-statement
+    := "if" expression ":" suite elif-part* else-part?
+    :tag :if)
+
+(defrule else-part
+    :=  "else" ":" suite)
+
+(defrule elif-part
+    := "elif" expression ":" suite)
+
+(defrule lambda-expression
+    := "lambda" method-arguments ":" expression
+    :tag :lambda)
+
+(defrule function-call
+    := (+ identifier ".") "(" (* expression ",") ")"
+    :tag :funcall)
+
+(defrule for-statement
+    := "for" identifier "in" expression ":" suite
+    :tag :do-list
+    := "for" identifier "in" "range" "(" expression "," expression ")" ":" suite
+    :tag :do-range)
+
+(defrule while-statement
+    := "while" expression ":" suite
+    :tag :while)
+
+(defrule return-statement
+    := "return" expression?
+    :tag :return)
+
+(defrule assert-statement
+    := "assert" expression "," string
+    :tag :assert)
+
+(defrule pass-statement
+    := "pass"
+    :tag :pass)
+
+(defrule break-statement
+    := "break"
+    :tag :break)
+
+(defrule continue-statement
+    := "continue"
+    :tag :continue)
+
+)					; end of POPULATE-GRAMMAR
diff --git a/third_party/lisp/npg/examples/vs-cobol-ii.lisp b/third_party/lisp/npg/examples/vs-cobol-ii.lisp
new file mode 100644
index 0000000000..2edf1292da
--- /dev/null
+++ b/third_party/lisp/npg/examples/vs-cobol-ii.lisp
@@ -0,0 +1,1901 @@
+;;;  vs-cobol-ii.lisp --- sample grammar for VS-Cobol II
+
+;;;  Copyright (C) 2003 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+;;;  $Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+;;;  Commentary:
+;;;
+;;; A fairly incomplete VS-Cobol II grammar fro NPG.  It's probably
+;;; not very accurate either.
+
+#+cmu (ext:file-comment "$Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $")
+
+(in-package :grammar)
+
+(defun make-keyword (string)
+  "Create a keyword from STRING."
+  (intern (string-upcase string) :keyword))
+
+(defun flatten-list (list)
+  "Remove one depth level in LIST."
+  (mapcan #'identity list))
+
+(deflazy define-grammar
+  (let ((*package* #.*package*)
+	(*compile-print* (and parser::*debug* t)))
+    (reset-grammar)
+    (format t "creating Cobol grammar...~%")
+    (populate-grammar)
+    (let ((grammar (parser:generate-grammar)))
+      (reset-grammar)
+      (parser:print-grammar-figures grammar)
+      grammar)))
+
+(defun populate-grammar ()
+;;;
+;;; Hereafter PP means Partial Program
+;;;
+
+#+nil
+(defrule pp--declarations
+    := identification-division environment-division? data-division? "PROCEDURE" "DIVISION" using-phrase? "." :rest)
+
+;;; We need to split the parsing of the declarations from the rest
+;;; because the declarations may change the lexical rules (ie decimal
+;;; point)
+
+(defrule pp--declarations
+    := identification-division environment-division? data-division-head-or-procedure-division-head :rest)
+
+(defrule data-division-head-or-procedure-division-head
+    := data-division-head
+    :reduce :data-division
+    := procedure-division-head
+    :reduce (list :procedure-division $1))
+
+(defrule pp--data-division
+    := data-division-content procedure-division-head :rest)
+
+(defrule pp--sentence
+    := sentence :rest
+    := :eof)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The real grammar
+;;;
+
+(defrule cobol-source-program
+    := identification-division environment-division? data-division procedure-division end-program?)
+
+(defrule identification-division
+    := identification "DIVISION" "." program-id-cobol-source-program identification-division-content
+    :reduce program-id-cobol-source-program)
+
+(defrule priority-number
+    := integer)
+
+(defrule level-number
+    := integer)
+
+(defrule to-id-or-lit
+    := "TO" id-or-lit)
+
+(defrule inspect-by-argument
+    := variable-identifier
+    := string
+    := figurative-constant-simple)
+
+(defrule figurative-constant-simple
+    := "ZERO"
+    :reduce :zero
+    := "ZEROS"
+    :reduce :zero
+    := "ZEROES"
+    :reduce :zero
+    := "SPACE"
+    :reduce :space
+    := "SPACES"
+    :reduce :space
+    := "HIGH-VALUE"
+    :reduce :high
+    := "HIGH-VALUES"
+    :reduce :high
+    := "LOW-VALUE"
+    :reduce :low
+    := "LOW-VALUES"
+    :reduce :low
+    := "QUOTE"
+    :reduce :quote
+    := "QUOTES"
+    :reduce :quote
+    := "NULL"
+    :reduce :null
+    := "NULLS"
+    :reduce :null)
+
+(defrule write-exceptions
+    := at-end-of-page-statement-list? not-at-end-of-page-statement-list? invalid-key-statement-list? not-invalid-key-statement-list?)
+
+(defrule set-statement-phrase
+    := variable-identifier+ set-oper set-src)
+
+(defrule set-src
+    := variable-identifier
+    := literal
+    := "TRUE"
+    := "ON"
+    := "OFF")
+
+(defrule set-oper
+    := "TO"
+    :reduce :to
+    := "UP" "BY"
+    :reduce :up
+    := "DOWN" "BY"
+    :reduce :down)
+
+(defrule fce-phrase
+    := reserve-clause
+    := fce-organization
+    := fce-access-mode
+    := record-key-clause
+    := password-clause
+    := alternate-record-key-clause
+    := file-status-clause
+    := padding-character-clause
+    := record-delimiter-clause)
+
+(defrule fce-organization
+    := organization-is? alt-indexed-relative-sequential
+    :reduce (list :organization (make-keyword alt-indexed-relative-sequential)))
+
+(defrule fce-access-mode
+    := "ACCESS" "MODE"? "IS"? alt-sequential-random-dynamic relative-key-clause?
+    :reduce (list :access-mode (make-keyword alt-sequential-random-dynamic)))
+
+(defrule alt-indexed-relative-sequential
+    := "INDEXED"
+    := "RELATIVE"
+    := "SEQUENTIAL")
+
+(defrule is-not
+    := "IS"? "NOT"?)
+
+(defrule all-procedures
+    := "ALL" "PROCEDURES")
+
+(defrule next-sentence
+    := "NEXT" "SENTENCE")
+
+(defrule no-rewind
+    := "NO" "REWIND")
+
+(defrule for-removal
+    := "FOR"? "REMOVAL")
+
+(defrule values
+    := "VALUE"
+    := "VALUES")
+
+(defrule records
+    := "RECORD"
+    := "RECORDS")
+
+(defrule end-program
+    := "END" "PROGRAM" program-name ".")
+
+(defrule environment-division
+    := "ENVIRONMENT" "DIVISION" "." environment-division-content)
+
+(defrule data-division-head
+    := "DATA" "DIVISION" ".")
+
+(defrule data-division
+    := data-division-head data-division-content
+    :reduce data-division-content)
+
+(defrule identification
+    := "IDENTIFICATION"
+    := "ID")
+
+(defrule identification-division-content
+    := identification-division-phrase*)
+
+(defrule author
+    := "AUTHOR" ".")
+
+(defrule installation
+    := "INSTALLATION" ".")
+
+(defrule date-written
+    := "DATE-WRITTEN" ".")
+
+(defrule date-compiled
+    := "DATE-COMPILED" ".")
+
+(defrule security
+    := "SECURITY" ".")
+
+(defrule remarks
+    := "REMARKS" ".")
+
+(defrule identification-division-phrase
+    := author
+    := installation
+    := date-written
+    := date-compiled
+    := security
+    := remarks)
+
+(defrule program-id-cobol-source-program
+    := "PROGRAM-ID" "."? program-name initial-program? "."
+    :reduce program-name)
+
+(defrule initial-program
+    := "IS"? "INITIAL" "PROGRAM"?)
+
+(defrule environment-division-content
+    := configuration-section? input-output-section?)
+
+(defrule input-output-section
+    := "INPUT-OUTPUT" "SECTION" "." file-control-paragraph? i-o-control-paragraph?
+    :reduce file-control-paragraph)
+
+(defrule file-control-paragraph
+    := "FILE-CONTROL" "." file-control-entry*)
+
+(defrule file-control-entry
+    := select-clause assign-clause fce-phrase* "."
+    :reduce (append select-clause
+		    assign-clause
+		    (flatten-list fce-phrase)))
+
+(defrule organization-is
+    := "ORGANIZATION" "IS"?)
+
+(defrule alt-sequential-random-dynamic
+    := "SEQUENTIAL"
+    := "RANDOM"
+    := "DYNAMIC")
+
+(defrule select-clause
+    := "SELECT" "OPTIONAL"? file-name
+    :reduce (list file-name :optional (and $2 t)))
+
+(defrule assign-clause
+    := "ASSIGN" "TO"? alt-assignment-name-literal+
+    :reduce (list :assign alt-assignment-name-literal))
+
+(defrule alt-assignment-name-literal
+    := assignment-name
+    := literal)
+
+(defrule reserve-clause
+    := "RESERVE" integer areas?)
+
+(defrule areas
+    := "AREA"
+    := "AREAS")
+
+(defrule padding-character-clause
+    := "PADDING" "CHARACTER"? "IS"? alt-qualified-data-name-literal)
+
+(defrule record-delimiter-clause
+    := "RECORD" "DELIMITER" "IS"? record-delimiter-name)
+
+(defrule record-delimiter-name
+    := "STANDARD-1"
+    := assignment-name)
+
+(defrule password-clause
+    := "PASSWORD" "IS"? data-name)
+
+(defrule file-status-clause
+    := "FILE"? "STATUS" "IS"? qualified-data-name qualified-data-name?
+    :reduce (list :file-status qualified-data-name))
+
+(defrule relative-key-clause
+    := "RELATIVE" "KEY"? "IS"? qualified-data-name
+    :reduce (list :relative-key qualified-data-name))
+
+(defrule record-key-clause
+    := "RECORD" "KEY"? "IS"? qualified-data-name
+    :reduce (list :key qualified-data-name))
+
+(defrule alternate-record-key-clause
+    := "ALTERNATE" "RECORD"? "KEY"? "IS"? qualified-data-name password-clause? with-duplicates?
+    :reduce (list :alternate-key qualified-data-name with-duplicates))
+
+(defrule with-duplicates
+    := "WITH"? "DUPLICATES")
+
+(defrule i-o-control-paragraph
+    := "I-O-CONTROL" "." i-o-sam? i-o-sort-merge?)
+
+(defrule i-o-sam
+    := qsam-or-sam-or-vsam-i-o-control-entries+ ".")
+
+(defrule i-o-sort-merge
+    := sort-merge-i-o-control-entries ".")
+
+(defrule qsam-or-sam-or-vsam-i-o-control-entries
+    := qsam-or-sam-or-vsam-i-o-control-entries-1
+    := qsam-or-sam-or-vsam-i-o-control-entries-2
+    := qsam-or-sam-or-vsam-i-o-control-entries-3
+    := qsam-or-sam-or-vsam-i-o-control-entries-4)
+
+(defrule qsam-or-sam-or-vsam-i-o-control-entries-1
+    := "RERUN" "ON" alt-assignment-name-file-name "EVERY"? every-phrase "OF"? file-name)
+
+(defrule every-phrase-1
+    := integer "RECORDS")
+
+(defrule every-phrase-2
+    := "END" "OF"? alt-reel-unit)
+
+(defrule every-phrase
+    := every-phrase-1
+    := every-phrase-2)
+
+(defrule alt-assignment-name-file-name
+    := assignment-name
+    := file-name)
+
+(defrule qsam-or-sam-or-vsam-i-o-control-entries-2
+    := "SAME" "RECORD"? "AREA"? "FOR"? file-name file-name+)
+
+(defrule qsam-or-sam-or-vsam-i-o-control-entries-3
+    := "MULTIPLE" "FILE" "TAPE"? "CONTAINS"? file-name-position+)
+
+(defrule position
+    := "POSITION" integer)
+
+(defrule file-name-position
+    := file-name position?)
+
+(defrule qsam-or-sam-or-vsam-i-o-control-entries-4
+    := "APPLY" "WRITE-ONLY" "ON"? file-name+)
+
+(defrule sort-merge-i-o-control-entries
+    := rerun-on? same-area+)
+
+(defrule rerun-on
+    := "RERUN" "ON" assignment-name)
+
+(defrule record-sort
+    := "RECORD"
+    := "SORT"
+    := "SORT-MERGE")
+
+(defrule same-area
+    := "SAME" record-sort "AREA"? "FOR"? file-name file-name+)
+
+(defrule configuration-section
+    := "CONFIGURATION" "SECTION" "." configuration-section-paragraph*
+    :reduce (flatten-list configuration-section-paragraph))
+
+(defrule configuration-section-paragraph
+    := source-computer-paragraph
+    := object-computer-paragraph
+    := special-names-paragraph)
+
+(defrule source-computer-paragraph
+    := "SOURCE-COMPUTER" "." source-computer-name
+    :reduce (list :source-computer source-computer-name))
+
+(defrule with-debugging-mode
+    := "WITH"? "DEBUGGING" "MODE")
+
+(defrule source-computer-name
+    := computer-name with-debugging-mode? "."
+    :reduce computer-name)
+
+(defrule object-computer-paragraph
+    := "OBJECT-COMPUTER" "." object-computer-name
+    :reduce (list :object-computer object-computer-name))
+
+(defrule memory-size-type
+    := "WORDS"
+    := "CHARACTERS"
+    := "MODULES")
+
+(defrule memory-size
+    := "MEMORY" "SIZE"? integer memory-size-type)
+
+(defrule object-computer-name
+    := computer-name memory-size? object-computer-paragraph-sequence-phrase "."
+    :reduce computer-name)
+
+(defrule object-computer-paragraph-sequence-phrase
+    := program-collating-sequence? segment-limit?)
+
+(defrule program-collating-sequence
+    := "PROGRAM"? "COLLATING"? "SEQUENCE" "IS"? alphabet-name)
+
+(defrule segment-limit
+    := "SEGMENT-LIMIT" "IS"? priority-number)
+
+(defrule special-names-paragraph
+    := "SPECIAL-NAMES" "." special-names-paragraph-phrase* special-names-paragraph-clause* "."
+    :reduce (flatten-list special-names-paragraph-clause))
+
+(defrule is-mnemonic-name
+    := "IS"? mnemonic-name special-names-paragraph-status-phrase?)
+
+(defrule special-names-paragraph-phrase-tail
+    := is-mnemonic-name
+    := special-names-paragraph-status-phrase)
+
+(defrule special-names-paragraph-phrase
+    := environment-name special-names-paragraph-phrase-tail)
+
+(defrule special-names-paragraph-status-phrase
+    := special-names-paragraph-status-phrase-1
+    := special-names-paragraph-status-phrase-2)
+
+(defrule special-names-paragraph-status-phrase-1
+    := "ON" "STATUS"? "IS"? condition off-status?)
+
+(defrule off-status
+    := "OFF" "STATUS"? "IS"? condition)
+
+(defrule special-names-paragraph-status-phrase-2
+    := "OFF" "STATUS"? "IS"? condition on-status?)
+
+(defrule on-status
+    := "ON" "STATUS"? "IS"? condition)
+
+(defrule special-names-paragraph-clause
+    ;; := alphabet-clause
+    ;; := symbolic-characters-clause
+    := currency-sign-clause
+    := decimal-point-clause)
+
+(defrule alphabet-clause
+    := "ALPHABET" alphabet-name "IS"? alphabet-type)
+
+(defrule alphabet-type-also
+    := "ALSO" literal)
+
+(defrule alphabet-type-alsos
+    := alphabet-type-also+)
+
+(defrule alphabet-type-also-through
+    := through-literal
+    := alphabet-type-alsos)
+
+(defrule alphabet-type-other
+    := literal alphabet-type-also-through?)
+
+(defrule alphabet-type-others
+    := alphabet-type-other+)
+
+(defrule alphabet-type
+    := "STANDARD-1"
+    := "STANDARD-2"
+    := "NATIVE"
+    := "EBCDIC"
+    := alphabet-type-others)
+
+(defrule symbolic-characters-clause
+    := "SYMBOLIC" "CHARACTERS"? symbolic-character-mapping+ in-alphabet-name?)
+
+(defrule are
+    := "ARE"
+    := "IS")
+
+(defrule symbolic-character-mapping
+    := symbolic-character+ are? integer+)
+
+(defrule in-alphabet-name
+    := "IN" alphabet-name)
+
+(defrule currency-sign-clause
+    := "CURRENCY" "SIGN"? "IS"? literal
+    :reduce (list :currency-sign literal))
+
+(defrule decimal-point-clause
+    := "DECIMAL-POINT" "IS"? "COMMA"
+    :reduce (list :decimal-point #\,))
+
+(defrule data-division-content
+    := file-section? working-storage-section? linkage-section?)
+
+(defrule file-section-entry
+    := file-and-sort-description-entry data-description-entry+
+    :reduce (cons file-and-sort-description-entry data-description-entry))
+
+(defrule file-section-head
+    := "FILE" "SECTION" ".")
+
+(defrule file-section
+    := file-section-head file-section-entry*
+    :reduce $2)
+
+(defrule working-storage-section-head
+    := "WORKING-STORAGE" "SECTION" ".")
+
+(defrule working-storage-section
+    := working-storage-section-head data-description-entry*
+    :reduce $2)
+
+(defrule linkage-section-head
+    := "LINKAGE" "SECTION" ".")
+
+(defrule linkage-section
+    := linkage-section-head data-description-entry*
+    :reduce $2)
+
+(defrule file-and-sort-description-entry
+    := alt-fd-sd file-name file-and-sort-description-entry-clause* "."
+    :reduce (list (make-keyword alt-fd-sd) file-name file-and-sort-description-entry-clause))
+
+(defrule alt-fd-sd
+    := "FD"
+    := "SD")
+
+(defrule file-and-sort-description-entry-clause
+    := external-clause
+    := global-clause
+    := block-contains-clause
+    := record-clause
+    := label-records-clause
+    := value-of-clause
+    := data-records-clause
+    := linage-clause
+    := recording-mode-clause
+    := code-set-clause)
+
+(defrule integer-to
+    := integer "TO")
+
+(defrule block-contains-clause
+    := "BLOCK" "CONTAINS"? integer-to? integer alt-characters-records?)
+
+(defrule alt-characters-records
+    := "CHARACTERS"
+    := "RECORDS"
+    := "RECORD")
+
+(defrule record-clause
+    := "RECORD" record-clause-tail)
+
+(defrule depending-on
+    := "DEPENDING" "ON"? data-name)
+
+(defrule record-clause-tail-1
+    := "CONTAINS"? integer "CHARACTERS"?)
+
+(defrule record-clause-tail-2
+    := "CONTAINS"? integer "TO" integer "CHARACTERS"?)
+
+(defrule record-clause-tail-3
+    := record-varying-phrase depending-on?)
+
+(defrule record-clause-tail
+    := record-clause-tail-2
+    := record-clause-tail-1
+    := record-clause-tail-3)
+
+(defrule record-varying-phrase
+    := "IS"? "VARYING" "IN"? "SIZE"? from-integer? to-integer? "CHARACTERS"?)
+
+(defrule from-integer
+    := "FROM"? integer)
+
+(defrule to-integer
+    := "TO" integer)
+
+(defrule label-records-clause
+    := "LABEL" records-are label-records-clause-tail
+    :reduce (list :label-record label-records-clause-tail))
+
+(defrule data-names
+    := data-name+)
+
+(defrule label-records-clause-tail
+    := "STANDARD" :reduce :standard
+    := "OMITTED" :reduce :omitted
+    := data-names)
+
+(defrule value-of-clause
+    := "VALUE" "OF" value-of-clause-tail+)
+
+(defrule alt-qualified-data-name-literal
+    := qualified-data-name
+    := literal)
+
+(defrule value-of-clause-tail
+    := variable-identifier "IS"? alt-qualified-data-name-literal)
+
+(defrule data-records-clause
+    := "DATA" records-are data-name+)
+
+(defrule records-are
+    := records are?)
+
+(defrule linage-clause
+    := "LINAGE" "IS"? alt-data-name-integer "LINES"? linage-footing-phrase)
+
+(defrule linage-footing-phrase
+    := footing? lines-top? lines-bottom?)
+
+(defrule alt-data-name-integer
+    := data-name
+    := integer)
+
+(defrule footing
+    := "WITH"? "FOOTING" "AT"? alt-data-name-integer)
+
+(defrule lines-top
+    := "LINES"? "AT"? "TOP" alt-data-name-integer)
+
+(defrule lines-bottom
+    := "LINES"? "AT"? "BOTTOM" alt-data-name-integer)
+
+(defrule recording-mode-clause
+    := "RECORDING" "MODE"? "IS"? variable-identifier)
+
+(defrule code-set-clause
+    := "CODE-SET" "IS"? alphabet-name)
+
+(defrule data-description-entry
+    := level-number alt-data-name-filler? data-description-entry-clause* "."
+    :reduce (append (list level-number alt-data-name-filler)
+		    (flatten-list data-description-entry-clause)))
+
+(defrule alt-data-name-filler
+    := data-name
+    := "FILLER"
+    :reduce (list))
+
+(defrule data-description-entry-clause
+    := picture-clause
+    := redefines-clause
+    := blank-when-zero-clause
+    := external-clause
+    := global-clause
+    := justified-clause
+    := occurs-clause
+    := sign-clause
+    := synchronized-clause
+    := usage-clause
+    := renames-clause
+    := value-clause)
+
+(defrule value-clause
+    := "VALUE" "IS"? literal
+    :reduce (list :value literal))
+
+(defrule redefines-clause
+    := "REDEFINES" data-name
+    :reduce `(:redefines ,data-name))
+
+(defrule blank-when-zero-clause
+    := "BLANK" "WHEN"? zeroes
+    :reduce '(:blank-when-zero t))
+
+(defrule zeroes
+    := "ZERO"
+    := "ZEROS"
+    := "ZEROES")
+
+(defrule external-clause
+    := "IS"? "EXTERNAL"
+    :reduce '(:external t))
+
+(defrule global-clause
+    := "IS"? "GLOBAL"
+    :reduce '(:global t))
+
+(defrule justified-clause
+    := justified "RIGHT"?
+    :reduce `(:justified ,(if $2 :right :left)))
+
+(defrule justified
+    := "JUSTIFIED"
+    := "JUST")
+
+(defrule occurs-clause
+    := "OCCURS" integer "TIMES"? occurs-clause-key* indexed-by?
+    ;; to be completed -wcp16/7/03.
+    :reduce `(:times ,integer)
+    := "OCCURS" integer "TO" integer "TIMES"? "DEPENDING" "ON"? qualified-data-name occurs-clause-key* indexed-by?
+    ;; to be completed -wcp16/7/03.
+    :reduce `(:times (,integer ,integer2 ,qualified-data-name)))
+
+(defrule occurs-clause-key
+    := alt-ascending-descending "KEY"? "IS"? qualified-data-name+)
+
+(defrule indexed-by
+    := "INDEXED" "BY"? index-name+)
+
+(defrule picture-clause
+    := picture "IS"? picture-string
+    :reduce `(:picture ,picture-string))
+
+(defrule picture
+    := "PICTURE"
+    := "PIC")
+
+(defrule sign-clause
+    := sign-is? alt-leading-trailing separate-character?
+    :reduce `(:separate-sign ,separate-character :sign-position ,alt-leading-trailing))
+
+(defrule sign-is
+    := "SIGN" "IS"?)
+
+(defrule separate-character
+    := "SEPARATE" "CHARACTER"?
+    :reduce t)
+
+(defrule alt-leading-trailing
+    := "LEADING"
+    :reduce :leading
+    := "TRAILING"
+    :reduce :trailing)
+
+(defrule synchronized-clause
+    := synchronized alt-left-right?
+    :reduce `(:synchronized ,(if alt-left-right
+				 alt-left-right
+				 t)))
+
+(defrule alt-left-right
+    := "LEFT"
+    :reduce :left
+    := "RIGHT"
+    :reduce :right)
+
+(defrule synchronized
+    := "SYNCHRONIZED"
+    := "SYNC")
+
+(defrule usage-clause
+    := usage-is? usage
+    :reduce (list :encoding usage))
+
+(defrule usage-is
+    := "USAGE" "IS"?)
+
+(defrule usage
+    := "BINARY"
+    :reduce :binary
+    := "COMP"
+    :reduce :comp
+    := "COMP-1"
+    :reduce :comp1
+    := "COMP-2"
+    :reduce :comp2
+    := "COMP-3"
+    :reduce :comp3
+    := "COMP-4"
+    :reduce :comp4
+    := "COMPUTATIONAL"
+    :reduce :comp
+    := "COMPUTATIONAL-1"
+    :reduce :comp1
+    := "COMPUTATIONAL-2"
+    :reduce :comp2
+    := "COMPUTATIONAL-3"
+    :reduce :comp3
+    := "COMPUTATIONAL-4"
+    :reduce :comp4
+    := "DISPLAY"
+    :reduce :display
+    := "DISPLAY-1"
+    :reduce :display1
+    := "INDEX"
+    :reduce :index
+    := "PACKED-DECIMAL"
+    :reduce :packed-decimal
+    := "POINTER"
+    :reduce :pointer)
+
+(defrule renames-clause
+    := "RENAMES" qualified-data-name through-qualified-data-name?
+    :reduce `(:renames ,qualified-data-name ,through-qualified-data-name))
+
+(defrule through-qualified-data-name
+    := through qualified-data-name
+    :reduce qualified-data-name)
+
+(defrule condition-value-clause
+    := values-are literal-through-literal+)
+
+(defrule through-literal
+    := through literal)
+
+(defrule literal-through-literal
+    := literal through-literal?)
+
+(defrule values-are
+    := values are?)
+
+(defrule procedure-division-head
+    := "PROCEDURE" "DIVISION" using-phrase? ".")
+
+(defrule procedure-division
+    := procedure-division-head sentence+)
+
+(defrule using-phrase
+    := "USING" data-name+)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defrule declaratives
+    := "DECLARATIVES" "." declaratives-content+ "END" "DECLARATIVES" ".")
+
+(defrule declaratives-content
+    := cobol-identifier "SECTION" "." use-statement "." sentence*)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defrule paragraph-header
+    := cobol-identifier "SECTION"?
+    :reduce (list (if $2 :section :label) $1))
+
+(defrule sentence
+    := declaratives
+    := statement* "."
+    :reduce $1
+    := paragraph-header "."
+    :reduce $1)
+
+(defrule statement
+    := move-statement
+    := if-statement
+    := perform-statement
+    := go-to-statement
+    := accept-statement
+    := add-statement
+    := alter-statement
+    := call-statement
+    := cancel-statement
+    := close-statement
+    := compute-statement
+    := continue-statement
+    := delete-statement
+    := display-statement
+    := divide-statement
+    := entry-statement
+    := evaluate-statement
+    := exit-program-statement
+    := exit-statement
+    := goback-statement
+    := initialize-statement
+    := inspect-statement
+    := merge-statement
+    := multiply-statement
+    := open-statement
+    := read-statement
+    := release-statement
+    := return-statement
+    := rewrite-statement
+    := search-statement
+    := set-statement
+    := sort-statement
+    := start-statement
+    := stop-statement
+    := string-statement
+    := subtract-statement
+    := unstring-statement
+    := write-statement
+    := paragraph-header)
+
+(defrule accept-statement
+    := "ACCEPT" variable-identifier "FROM" date
+    := "ACCEPT" variable-identifier "AT" screen-coordinates
+    :reduce (apply #'list 'accept-at variable-identifier screen-coordinates)
+    := "ACCEPT" variable-identifier from-environment-name?)
+
+(defrule from-environment-name
+    := "FROM" cobol-identifier)
+
+
+(defrule date
+    := "DATE"
+    := "DAY"
+    := "DAY-OF-WEEK"
+    := "TIME")
+
+(defrule add-statement
+    := "ADD" id-or-lit+ to-id-or-lit? "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?
+    := "ADD" id-or-lit+ "TO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?
+    := "ADD" corresponding variable-identifier "TO" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?)
+
+(defrule statement-list
+    := statement+)
+
+(defrule alter-statement
+    := "ALTER" procedure-to-procedure+)
+
+(defrule proceed-to
+    := "PROCEED" "TO")
+
+(defrule procedure-to-procedure
+    := procedure-name "TO" proceed-to? procedure-name)
+
+(defrule call-statement
+    := "CALL" id-or-lit using-parameters? call-rest-phrase "END-CALL"?
+    :reduce (list 'call id-or-lit (cons 'list using-parameters)))
+
+(defrule by-reference
+    := "BY"? "REFERENCE")
+
+(defrule content-parameter-value
+    := cobol-identifier
+    := literal)
+
+(defrule reference-parameter
+    := by-reference? variable-identifier)
+
+(defrule content-parameter
+    := "BY"? "CONTENT" content-parameter-value+)
+
+(defrule parameter
+    := reference-parameter
+    := content-parameter
+    := literal)
+
+(defrule using-parameters
+    := "USING" parameter+)
+
+(defrule call-rest-phrase
+    := on-exception-statement-list? not-on-exception-statement-list? on-overflow-statement-list?)
+
+(defrule on-exception-statement-list
+    := "ON"? "EXCEPTION" statement-list)
+
+(defrule not-on-exception-statement-list
+    := "NOT" "ON"? "EXCEPTION" statement-list)
+
+(defrule cancel-statement
+    := "CANCEL" id-or-lit+)
+
+(defrule close-statement
+    := "CLOSE" close-statement-file-name+
+    :reduce (list 'close close-statement-file-name))
+
+(defrule alt-removal-no-rewind
+    := for-removal
+    := with-no-rewind)
+
+(defrule alt-reel-unit
+    := "REEL"
+    := "UNIT")
+
+(defrule alt-no-rewind-lock
+    := no-rewind
+    := "LOCK")
+
+(defrule close-statement-options-1
+    := alt-reel-unit alt-removal-no-rewind?)
+
+(defrule close-statement-options-2
+    := "WITH"? alt-no-rewind-lock)
+
+(defrule close-statement-options
+    := close-statement-options-1
+    := close-statement-options-2)
+
+(defrule close-statement-file-name
+    := file-name close-statement-options?)
+
+(defrule compute-statement
+    := "COMPUTE" cobword-rounded+ equal arithmetic-expression on-size-error-statement-list? not-on-size-error-statement-list? "END-COMPUTE"?
+    :reduce (list 'compute cobword-rounded arithmetic-expression :on-size-error on-size-error-statement-list
+		  :not-on-size-error not-on-size-error-statement-list))
+
+(defrule equal
+    := "="
+    := "EQUAL")
+
+(defrule continue-statement
+    := "CONTINUE")
+
+(defrule delete-statement
+    := "DELETE" file-name "RECORD"? invalid-key-statement-list? not-invalid-key-statement-list? "END-DELETE"?
+    :reduce (list 'delete file-name :invalid invalid-key-statement-list :not-invalid not-invalid-key-statement-list))
+
+(defrule display-statement
+    := "DISPLAY" id-or-lit+ upon-environment-name? with-no-advancing?
+    :reduce (list 'display (cons 'list id-or-lit) :upon upon-environment-name :advance (not with-no-advancing))
+    := "DISPLAY" id-or-lit "AT" screen-coordinates
+    :reduce (apply #'list 'display-at id-or-lit screen-coordinates))
+
+(defrule screen-coordinates
+    := integer
+    :reduce (multiple-value-list (truncate integer 100)))
+
+(defrule upon-environment-name
+    := "UPON" cobol-identifier)
+
+(defrule with-no-advancing
+    := "WITH"? "NO" "ADVANCING")
+
+(defrule divide-statement
+    := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?
+    := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?
+    := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?
+    := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?
+    := "DIVIDE" id-or-lit "INTO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?)
+
+(defrule entry-statement
+    := "ENTRY" literal using-phrase?)
+
+(defrule evaluate-statement
+    := "EVALUATE" evaluate-condition also-phrase* when-phrases+ when-other-phrase? "END-EVALUATE"?)
+
+(defrule evaluate-condition
+    := condition
+    := "TRUE"
+    := "FALSE")
+
+(defrule also-phrase
+    := "ALSO" evaluate-condition)
+
+(defrule when-phrase-also-phrase
+    := "ALSO" evaluate-phrase)
+
+(defrule when-phrase
+    := "WHEN" evaluate-phrase when-phrase-also-phrase*)
+
+(defrule when-phrases
+    := when-phrase+ statement-list)
+
+(defrule when-other-phrase
+    := "WHEN" "OTHER" statement-list)
+
+(defrule evaluate-phrase
+    := "ANY"
+    := condition
+    := "TRUE"
+    := "FALSE"
+    := evaluate-phrase-1)
+
+(defrule evaluate-phrase-1
+    := "NOT"? arithmetic-expression through-arithmetic-expression?)
+
+(defrule through-arithmetic-expression
+    := through arithmetic-expression)
+
+(defrule exit-statement
+    := "EXIT"
+    :reduce '(exit-paragraph))
+
+(defrule exit-program-statement
+    := "EXIT" "PROGRAM"
+    :reduce '(exit-program))
+
+(defrule goback-statement
+    := "GOBACK"
+    :reduce '(go-back))
+
+(defrule go-to-statement
+    := "GO" "TO"? procedure-name+ "DEPENDING" "ON"? variable-identifier
+    :reduce (list 'goto-depending variable-identifier procedure-name)
+    := "GO" "TO"? procedure-name
+    :reduce (list 'goto procedure-name))
+
+(defrule if-phrase
+    := "IF" condition "THEN"? alt-statement-list-next-sentence "ELSE" alt-statement-list-next-sentence
+    :reduce (list 'if condition
+		  (if (cdr alt-statement-list-next-sentence)
+		      (cons 'progn alt-statement-list-next-sentence)
+		      (car alt-statement-list-next-sentence))
+		  (if (cdr alt-statement-list-next-sentence2)
+		      (cons 'progn alt-statement-list-next-sentence2)
+		      (car alt-statement-list-next-sentence2)))
+    := "IF" condition "THEN"? alt-statement-list-next-sentence
+    :reduce (append (list 'when condition) alt-statement-list-next-sentence))
+
+(defrule if-statement
+    := if-phrase "END-IF"?
+    :reduce $1)
+
+(defrule initialize-statement
+    := "INITIALIZE" variable-identifier+ initialize-replacing-phrase?)
+
+(defrule initialize-replacing-type
+    := "ALPHABETIC"
+    := "ALPHANUMERIC"
+    := "NUMERIC"
+    := "ALPHANUMERIC-EDITED"
+    := "NUMERIC-EDITED"
+    := "DBCS"
+    := "EGCS")
+
+(defrule initialize-replacing-argument
+    := initialize-replacing-type "DATA"? "BY" id-or-lit)
+
+(defrule initialize-replacing-phrase
+    := "REPLACING" initialize-replacing-argument+)
+
+(defrule inspect-statement
+    := inspect-statement-1
+    := inspect-statement-2
+    := inspect-statement-3
+    := inspect-statement-4)
+
+(defrule inspect-statement-1
+    := "INSPECT" variable-identifier "TALLYING" tallying-argument+)
+
+(defrule inspect-statement-2
+    := "INSPECT" variable-identifier "CONVERTING" id-or-lit "TO" id-or-lit before-after-phrase*)
+
+(defrule inspect-statement-3
+    := "INSPECT" variable-identifier "TALLYING" tallying-argument+ "REPLACING" inspect-replacing-phrase+)
+
+(defrule tallying-for-id-or-lit
+    := id-or-lit before-after-phrase*)
+
+(defrule alt-all-leading
+    := "ALL"
+    := "LEADING")
+
+(defrule tallying-for-argument-1
+    := "CHARACTERS" before-after-phrase*)
+
+(defrule tallying-for-argument-2
+    := alt-all-leading tallying-for-id-or-lit+)
+
+(defrule tallying-for-argument
+    := tallying-for-argument-1
+    := tallying-for-argument-2)
+
+(defrule tallying-argument
+    := variable-identifier "FOR" tallying-for-argument+)
+
+(defrule inspect-statement-4
+    := "INSPECT" variable-identifier "REPLACING" inspect-replacing-phrase+)
+
+(defrule inspect-replacing-argument
+    := inspect-by-argument "BY" inspect-by-argument before-after-phrase*)
+
+(defrule alt-all-leading-first
+    := "ALL"
+    := "LEADING"
+    := "FIRST")
+
+(defrule inspect-replacing-phrase-1
+    := "CHARACTERS" "BY" id-or-lit before-after-phrase*)
+
+(defrule inspect-replacing-phrase-2
+    := alt-all-leading-first inspect-replacing-argument+)
+
+(defrule inspect-replacing-phrase
+    := inspect-replacing-phrase-1
+    := inspect-replacing-phrase-2)
+
+(defrule before-after-phrase
+    := alt-before-after "INITIAL"? id-or-lit)
+
+(defrule merge-statement
+    := "MERGE" file-name on-key-phrase+ collating-sequence? "USING" file-name file-name+ merge-statement-tail)
+
+(defrule on-key-phrase
+    := "ON"? alt-ascending-descending "KEY"? qualified-data-name+)
+
+(defrule merge-statement-tail
+    := output-procedure
+    := giving-file-names)
+
+(defrule move-statement
+    := "MOVE" id-or-lit "TO" variable-identifier+
+    :reduce (apply #'list 'move id-or-lit variable-identifier)
+    := "MOVE" corresponding variable-identifier "TO" variable-identifier+
+    :reduce (apply #'list 'move-corresponding variable-identifier variable-identifier2))
+
+(defrule multiply-statement
+    := "MULTIPLY" id-or-lit "BY" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"?
+    :reduce (list 'multiply id-or-lit cobword-rounded :on-size-error on-size-error-statement-list
+		  :not-on-size-error not-on-size-error-statement-list)
+    := "MULTIPLY" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"?
+    :reduce (list 'multiply id-or-lit id-or-lit2 :giving cobword-rounded
+		  :on-size-error on-size-error-statement-list
+		  :not-on-size-error not-on-size-error-statement-list))
+
+(defrule open-statement
+    := "OPEN" open-statement-phrase+
+    :reduce (list 'open open-statement-phrase))
+
+(defrule alt-reversed-with-no-rewind
+    := "REVERSED"
+    := with-no-rewind)
+
+(defrule open-statement-input-file-name
+    := file-name alt-reversed-with-no-rewind?)
+
+(defrule with-no-rewind
+    := "WITH"? "NO" "REWIND")
+
+(defrule open-statement-output-file-name
+    := file-name with-no-rewind?)
+
+(defrule open-statement-input
+    := "INPUT" open-statement-input-file-name+)
+
+(defrule open-statement-output
+    := "OUTPUT" open-statement-output-file-name+)
+
+(defrule open-statement-i-o
+    := "I-O" file-name+)
+
+(defrule open-statement-extend
+    := "EXTEND" file-name+)
+
+(defrule open-statement-phrase
+    := open-statement-input
+    := open-statement-output
+    := open-statement-i-o
+    := open-statement-extend)
+
+(defrule perform-statement
+    := "PERFORM" procedure-name through-procedure-name? perform-until-phrase
+    :reduce `(perform-until ,procedure-name ,through-procedure-name ,perform-until-phrase)
+    := "PERFORM" procedure-name through-procedure-name? perform-varying-phrase perform-after-phrase*
+    :reduce `(perform-varying ,perform-varying-phrase ,procedure-name ,through-procedure-name ,perform-after-phrase)
+    := "PERFORM" procedure-name through-procedure-name? cobword-int "TIMES"
+    :reduce `(perform-times ,cobword-int ,procedure-name ,through-procedure-name)
+    := "PERFORM" procedure-name through-procedure-name?
+    :reduce (append (list 'perform procedure-name) through-procedure-name))
+
+(defrule perform-varying-phrase
+    := with-test? "VARYING" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition)
+
+(defrule perform-after-phrase
+    := "AFTER" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition)
+
+(defrule perform-until-phrase
+    := with-test? "UNTIL" condition)
+
+(defrule with-test
+    := "WITH"? "TEST" alt-before-after
+    :reduce alt-before-after)
+
+(defrule read-statement
+    := "READ" file-name "NEXT"? "RECORD"? into-identifier? key-is-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? at-end-statement-list? not-at-end-statement-list? "END-READ"?)
+
+(defrule key-is-qualified-data-name
+    := "KEY" "IS"? qualified-data-name)
+
+(defrule release-statement
+    := "RELEASE" record-name from-identifier?)
+
+(defrule return-statement
+    := "RETURN" file-name "RECORD"? into-identifier? "AT"? "END" statement-list not-at-end-statement-list? "END-RETURN"?)
+
+(defrule into-identifier
+    := "INTO" variable-identifier)
+
+(defrule not-at-end-statement-list
+    := "NOT" "AT"? "END" statement-list)
+
+(defrule rewrite-statement
+    := "REWRITE" record-name from-identifier? invalid-key-statement-list? not-invalid-key-statement-list? "END-REWRITE"?)
+
+(defrule search-statement
+    := search-statement-1
+    := search-statement-2)
+
+(defrule search-statement-1
+    := "SEARCH" cobol-identifier varying-identifier? at-end-statement-list? when-condition-stats+ "END-SEARCH"?)
+
+(defrule varying-identifier
+    := "VARYING" variable-identifier)
+
+(defrule when-condition-stats
+    := "WHEN" condition alt-statement-list-next-sentence)
+
+(defrule search-statement-2
+    := "SEARCH" "ALL" variable-identifier at-end-statement-list? "WHEN" search-statement-condition search-statement-condition-tail* alt-statement-list-next-sentence "END-SEARCH"?)
+
+(defrule at-end-statement-list
+    := "AT"? "END" statement-list)
+
+(defrule search-statement-equal-expression
+    := variable-identifier "IS"? equal-to arithmetic-expression
+    :reduce (list '= variable-identifier arithmetic-expression))
+
+(defrule search-statement-condition
+    := search-statement-equal-expression
+    := condition-name-reference)
+
+(defrule search-statement-condition-tail
+    := "AND" search-statement-condition)
+
+(defrule alt-statement-list-next-sentence
+    := statement+
+    := next-sentence
+    :reduce :next-sentence)
+
+(defrule set-statement
+    := "SET" set-statement-phrase+)
+
+(defrule sort-statement
+    := "SORT" file-name on-key-is-phrase+ with-duplicates-in-order? collating-sequence? sort-statement-in sort-statement-out)
+
+(defrule key-is
+    := "KEY" "IS"?)
+
+(defrule alt-ascending-descending
+    := "ASCENDING"
+    := "DESCENDING")
+
+(defrule on-key-is-phrase
+    := "ON"? alt-ascending-descending key-is? qualified-data-name+)
+
+(defrule with-duplicates-in-order
+    := "WITH"? "DUPLICATES" "IN"? "ORDER"?)
+
+(defrule collating-sequence
+    := "COLLATING"? "SEQUENCE" "IS"? alphabet-name)
+
+(defrule through
+    := "THROUGH"
+    := "THRU")
+
+(defrule through-procedure-name
+    := through procedure-name
+    :reduce procedure-name)
+
+(defrule using-file-names
+    := "USING" file-name+)
+
+(defrule input-procedure
+    := "INPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?)
+
+(defrule giving-file-names
+    := "GIVING" file-name+)
+
+(defrule output-procedure
+    := "OUTPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?)
+
+(defrule sort-statement-in
+    := using-file-names
+    := input-procedure)
+
+(defrule sort-statement-out
+    := giving-file-names
+    := output-procedure)
+
+(defrule start-statement
+    := "START" file-name key-is-rel-op-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? "END-START"?)
+
+(defrule rel-op
+    := equal-to
+    :reduce '=
+    := greater-than
+    :reduce '>
+    := greater-equal
+    :reduce '>=)
+
+(defrule key-is-rel-op-qualified-data-name
+    := "KEY" "IS"? rel-op qualified-data-name
+    :reduce (list rel-op qualified-data-name))
+
+(defrule stop-statement
+    := "STOP" alt-run-literal
+    :reduce '(stop))
+
+(defrule alt-run-literal
+    := "RUN"
+    := literal)
+
+(defrule string-statement
+    := "STRING" delimited-by-phrase+ "INTO" variable-identifier with-pointer-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-STRING"?
+    :reduce (list 'string-concat delimited-by-phrase variable-identifier :with-pointer with-pointer-identifier :on-overflow on-overflow-statement-list :not-on-overflow not-on-overflow-statement-list))
+
+(defrule id-or-lit-size
+    := literal
+    := variable-identifier
+    := "SIZE")
+
+(defrule delimited-by-phrase
+    := id-or-lit+ "DELIMITED" "BY"? id-or-lit-size
+    :reduce (list id-or-lit id-or-lit-size))
+
+(defrule subtract-statement
+    := "SUBTRACT" id-or-lit+ "FROM" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"?
+    :reduce (list 'subtract-giving id-or-lit id-or-lit2 cobword-rounded
+		  :on-size-error on-size-error-statement-list
+		  :not-on-size-error not-on-size-error-statement-list)
+    := "SUBTRACT" id-or-lit+ "FROM" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"?
+    :reduce (list 'subtract id-or-lit cobword-rounded
+		  :on-size-error on-size-error-statement-list
+		  :not-on-size-error not-on-size-error-statement-list)
+    := "SUBTRACT" corresponding variable-identifier "FROM" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"?
+    :reduce (list 'subtract-corr variable-identifier variable-identifier
+		  :rounded (and $5 t)
+		  :on-size-error on-size-error-statement-list
+		  :not-on-size-error not-on-size-error-statement-list))
+
+(defrule cobword-rounded
+    := variable-identifier "ROUNDED"?
+    :reduce (list variable-identifier (and $2 t)))
+
+(defrule on-size-error-statement-list
+    := "ON"? "SIZE" "ERROR" statement-list
+    :reduce statement-list)
+
+(defrule not-on-size-error-statement-list
+    := "NOT" "ON"? "SIZE" "ERROR" statement-list
+    :reduce statement-list)
+
+(defrule corresponding
+    := "CORRESPONDING"
+    := "CORR")
+
+(defrule unstring-statement
+    := "UNSTRING" variable-identifier delimited-by-all-phrase? "INTO" unstring-statement-dst+ with-pointer-identifier? tallying-in-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-UNSTRING"?
+    :reduce (list 'unstring variable-identifier unstring-statement-dst
+		  :delimited-by-all delimited-by-all-phrase
+		  :with-pointer with-pointer-identifier
+		  :tallying tallying-in-identifier
+		  :on-overflow on-overflow-statement-list
+		  :not-on-overflow not-on-overflow-statement-list))
+
+(defrule id-or-lit
+    := literal
+    := variable-identifier)
+
+(defrule or-all-id-or-lit
+    := "OR" "ALL"? id-or-lit)
+
+(defrule delimited-by-all-phrase
+    := "DELIMITED" "BY"? "ALL"? id-or-lit or-all-id-or-lit*)
+
+(defrule delimiter-in-identifier
+    := "DELIMITER" "IN"? variable-identifier)
+
+(defrule count-in-identifier
+    := "COUNT" "IN"? variable-identifier)
+
+(defrule unstring-statement-dst
+    := variable-identifier delimiter-in-identifier? count-in-identifier?)
+
+(defrule with-pointer-identifier
+    := "WITH"? "POINTER" variable-identifier)
+
+(defrule tallying-in-identifier
+    := "TALLYING" "IN"? variable-identifier)
+
+(defrule on-overflow-statement-list
+    := "ON"? "OVERFLOW" statement-list)
+
+(defrule not-on-overflow-statement-list
+    := "NOT" "ON"? "OVERFLOW" statement-list)
+
+(defrule write-statement
+    := "WRITE" record-name from-identifier? advancing-phrase? write-exceptions "END-WRITE"?)
+
+(defrule lines
+    := "LINE"
+    := "LINES")
+
+(defrule cobword-int
+    := cobol-identifier
+    := integer)
+
+(defrule nr-lines-phrase
+    := cobword-int lines?)
+
+(defrule page-phrase
+    := nr-lines-phrase
+    := "PAGE")
+
+(defrule alt-before-after
+    := "BEFORE"
+    := "AFTER")
+
+(defrule advancing-phrase
+    := alt-before-after "ADVANCING"? page-phrase)
+
+(defrule from-identifier
+    := "FROM" variable-identifier)
+
+(defrule invalid-key-statement-list
+    := "INVALID" "KEY"? statement-list
+    :reduce statement-list)
+
+(defrule not-invalid-key-statement-list
+    := "NOT" "INVALID" "KEY"? statement-list
+    :reduce statement-list)
+
+(defrule end-of-page
+    := "END-OF-PAGE"
+    := "EOP")
+
+(defrule at-end-of-page-statement-list
+    := "AT"? end-of-page statement-list
+    :reduce statement-list)
+
+(defrule not-at-end-of-page-statement-list
+    := "NOT" "AT"? end-of-page statement-list
+    :reduce statement-list)
+
+;; This is left in the grammar but is not used.  COPYs are handled by
+;; the lexical scanner.
+(defrule copy-statement
+    := "COPY" alt-text-name-literal in-library? "SUPPRESS"? copy-statement-replacing-phrase?)
+
+(defrule in
+    := "OF"
+    := "IN")
+
+(defrule alt-library-name-literal
+    := library-name
+    := literal)
+
+(defrule in-library
+    := in alt-library-name-literal)
+
+(defrule copy-statement-by-phrase
+    := copy-operand "BY" copy-operand)
+
+(defrule copy-statement-replacing-phrase
+    := "REPLACING" copy-statement-by-phrase+)
+
+(defrule alt-text-name-literal
+    := text-name
+    := literal)
+
+(defrule copy-operand
+    := cobol-identifier
+    := literal)
+
+(defrule use-statement
+    := use-statement-1
+    := use-statement-2
+    := use-statement-3)
+
+(defrule use-statement-1
+    := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-exception-error "PROCEDURE" "ON"? alt-file-names-i-o)
+
+(defrule alt-exception-error
+    := "EXCEPTION"
+    := "ERROR")
+
+(defrule use-statement-2
+    := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-beginning-ending? alt-file-reel-unit? "LABEL" "PROCEDURE" "ON"? alt-file-names-i-o)
+
+(defrule alt-beginning-ending
+    := "BEGINNING"
+    := "ENDING")
+
+(defrule alt-file-reel-unit
+    := "FILE"
+    := "REEL"
+    := "UNIT")
+
+(defrule file-names
+    := file-name+)
+
+(defrule alt-file-names-i-o
+    := file-names
+    := "INPUT"
+    := "OUTPUT"
+    := "I-O"
+    := "EXTEND")
+
+(defrule use-statement-3
+    := "USE" "FOR"? "DEBUGGING" "ON"? alt-procedures-all-procedures)
+
+(defrule procedure-names
+    := procedure-name+)
+
+(defrule alt-procedures-all-procedures
+    := procedure-names
+    := all-procedures)
+
+(defrule condition
+    := combinable-condition
+    := combinable-condition "AND" condition
+    :reduce `(and ,combinable-condition ,condition)
+    := combinable-condition "OR" condition
+    :reduce `(or ,combinable-condition ,condition)
+    := combinable-condition "AND" id-or-lit
+    :reduce `(and ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit))
+    := combinable-condition "OR" id-or-lit
+    :reduce `(or ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit)))
+
+(defrule combinable-condition
+    := "NOT"? simple-condition
+    :reduce (if $1
+		(list 'not simple-condition)
+		simple-condition))
+
+(defrule simple-condition
+    := class-condition
+    := relation-condition
+    := sign-condition
+    := "(" condition ")"
+    ;; not sure if it's necessary -wcp15/7/03.
+    ;; := arithmetic-expression
+    )
+
+(defrule class-condition
+    := variable-identifier "IS"? "NOT"? class-type
+    :reduce (if $3
+		(list 'not (list 'type-of variable-identifier (make-keyword class-type)))
+		(list 'type-of variable-identifier (make-keyword class-type))))
+
+(defrule class-type
+    := "NUMERIC"
+    := "ALPHABETIC"
+    := "ALPHABETIC-LOWER"
+    := "ALPHABETIC-UPPER"
+    := "DBCS")
+
+(defun unfold-subrelations (main-relation subs)
+  (destructuring-bind (main-operator main-variable other-variable) main-relation
+    (declare (ignore other-variable))
+    (labels ((unfold (subs)
+	       (if (null subs)
+		   main-relation
+		   (destructuring-bind (connection operator variable) (car subs)
+		     (list connection
+			   (list (or operator main-operator) main-variable variable)
+			   (unfold (cdr subs)))))))
+      (unfold subs))))
+
+(defrule relation-condition
+    ;; This is too complex
+    ;; := arithmetic-expression relational-operator simple-condition
+    := id-or-lit relational-operator id-or-lit subordinate-relation*
+    :reduce (unfold-subrelations (list relational-operator id-or-lit id-or-lit2) subordinate-relation))
+
+(defrule or-and
+    := "OR" :reduce 'or
+    := "AND" :reduce 'and)
+
+(defrule subordinate-relation
+    := or-and relational-operator? id-or-lit
+    :reduce (list or-and relational-operator id-or-lit))
+
+(defrule relational-operator
+    := "IS"? relational-operator-type
+    :reduce relational-operator-type)
+
+(defrule less-than
+    := "LESS" "THAN"?
+    := "<")
+
+(defrule greater-equal
+    := "GREATER" "THAN"? "OR" "EQUAL" "TO"?
+    := ">="
+    := ">" "="
+    := "NOT" "<"
+    := "NOT" "LESS" "THAN"?)
+
+(defrule less-equal
+    := "LESS" "THAN"? "OR" "EQUAL" "TO"?
+    := "<="
+    := "<" "="
+    := "NOT" ">"
+    := "NOT" "GREATER" "THAN"?)
+
+(defrule greater-than
+    := "GREATER" "THAN"?
+    := ">")
+
+(defrule equal-to
+    := "EQUAL" "TO"?
+    := "=")
+
+(defrule relational-operator-type
+    := greater-equal
+    :reduce 'cob>=
+    := less-equal
+    :reduce 'cob<=
+    := greater-than
+    :reduce 'cob>
+    := less-than
+    :reduce 'cob<
+    := equal-to
+    :reduce 'cob=
+    := "NOT" equal-to
+    :reduce 'cob-not=)
+
+(defrule sign-condition
+    := arithmetic-expression "IS"? "NOT"? sign-type
+    :reduce (if $3
+		`(not (,sign-type ,arithmetic-expression))
+		`(,sign-type ,arithmetic-expression)))
+
+(defrule sign-type
+    := "POSITIVE" :reduce '>
+    := "NEGATIVE" :reduce '<
+    := "ZERO" :reduce '=
+    := "ZEROES" :reduce '=
+    := "ZEROS" :reduce '=)
+
+(defrule procedure-name
+    := paragraph-or-section-name in-section-name
+    :reduce (list paragraph-or-section-name in-section-name)
+    := paragraph-or-section-name
+    :reduce paragraph-or-section-name)
+
+(defrule in-section-name
+    := in cobol-identifier
+    :reduce cobol-identifier)
+
+(defrule variable-identifier
+    := qualified-data-name subscript-parentheses* ;; reference-modification?
+    :reduce (if subscript-parentheses
+		(list :aref qualified-data-name subscript-parentheses)
+		qualified-data-name))
+
+(defrule reference-modification
+    := "(" leftmost-character-position ":" length? ")"
+    :reduce (if length
+		(list :range leftmost-character-position length)
+		leftmost-character-position))
+
+(defrule condition-name-reference
+    := condition-name in-data-or-file-or-mnemonic-name* subscript-parentheses*)
+
+(defrule in-data-or-file-or-mnemonic-name
+    := in data-or-file-or-mnemonic-name)
+
+(defrule subscript-parentheses
+    := "(" subscript ")")
+
+(defrule subscript
+    := subscript-expression+)
+
+(defrule plus-minus-integer
+    := plus-or-minus integer)
+
+(defrule subscript-expression-ambiguous
+    := qualified-data-name plus-minus-integer?)
+
+(defrule subscript-expression
+    := literal
+    := subscript-expression-ambiguous)
+
+(defrule qualified-data-name
+    := data-name in-data-or-file-name*
+    :reduce (if in-data-or-file-name
+		(list data-name in-data-or-file-name) ; incomplete -wcp15/7/03.
+		data-name)
+    := "ADDRESS" "OF" data-name
+    :reduce (list 'address-of data-name)
+    := "LENGTH" "OF" cobol-identifier
+    :reduce (list 'length-of cobol-identifier))
+
+(defrule in-data-or-file-name
+    := in data-or-file-name)
+
+(defrule leftmost-character-position
+    := arithmetic-expression)
+
+(defrule length
+    := arithmetic-expression)
+
+(defrule arithmetic-expression
+    := times-div
+    := times-div "+" arithmetic-expression
+    :reduce `(+ ,times-div ,arithmetic-expression)
+    := times-div "-" arithmetic-expression
+    :reduce `(- ,times-div ,arithmetic-expression))
+
+(defrule times-div
+    := power
+    := power "*" times-div
+    :reduce `(* ,power ,times-div)
+    := power "/" times-div
+    :reduce `(/ ,power ,times-div))
+
+(defrule power
+    := plus-or-minus? basis
+    := plus-or-minus? basis "**" power
+    :reduce (if plus-or-minus
+		`(plus-or-minus (expt basis basis2))
+		`(expt basis basis2)))
+
+(defrule plus-or-minus
+    := "+"
+    :reduce '+
+    := "-"
+    :reduce '-)
+
+;; (defrule power-tail
+;;     := "**" basis)
+
+(defrule basis
+    := literal
+    := variable-identifier
+    := "(" arithmetic-expression ")")
+
+(defrule alphabet-name
+    := cobol-identifier)
+
+(defrule condition-name
+    := cobol-identifier)
+
+(defrule data-name
+    := cobol-identifier)
+
+(defrule cobol-identifier
+    := identifier
+    :reduce (intern (string-upcase identifier)))
+
+(defrule file-name
+    := cobol-identifier)
+
+(defrule data-or-file-name
+    := cobol-identifier)
+
+(defrule index-name
+    := cobol-identifier)
+
+(defrule mnemonic-name
+    := cobol-identifier)
+
+(defrule data-or-file-or-mnemonic-name
+    := cobol-identifier)
+
+(defrule record-name
+    := qualified-data-name)
+
+(defrule symbolic-character
+    := cobol-identifier)
+
+(defrule library-name
+    := cobol-identifier)
+
+(defrule program-name
+    := cobol-identifier
+    := string)
+
+(defrule text-name
+    := cobol-identifier)
+
+(defrule paragraph-or-section-name
+    := cobol-identifier
+    := integer)
+
+(defrule computer-name
+    := identifier)
+
+(defrule environment-name
+    := cobol-identifier)
+
+(defrule assignment-name
+    := cobol-identifier)
+
+(defrule figurative-constant
+    := figurative-constant-simple
+    := figurative-constant-all)
+
+(defrule figurative-constant-all
+    := "ALL" literal)
+
+(defrule literal
+    := string
+    := float
+    := integer
+    := figurative-constant)
+
+)					; defun populate-grammar
diff --git a/third_party/lisp/npg/npg.asd b/third_party/lisp/npg/npg.asd
new file mode 100644
index 0000000000..addb7c6932
--- /dev/null
+++ b/third_party/lisp/npg/npg.asd
@@ -0,0 +1,55 @@
+;;;  npg.asd --- declaration of this system
+
+;;;  Copyright (C) 2003, 2006 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+
+#+cmu (ext:file-comment "$Module: npg.asd, Time-stamp: <2006-01-03 17:20:21 wcp> $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(defpackage :npg-system
+  (:use :common-lisp :asdf))
+
+(in-package :npg-system)
+
+(defclass sample-file (doc-file) ())
+(defmethod source-file-type ((c sample-file) (s module))
+  "lisp")
+
+(defsystem npg
+  :name "NPG"
+  :author "Walter C. Pelissero <walter@pelissero.de>"
+  :maintainer "Walter C. Pelissero <walter@pelissero.de>"
+  :licence "Lesser General Public License"
+  :description "NPG a Naive Parser Generator"
+  :long-description
+  "NPG is a backtracking recursive descent parser generator for
+Common Lisp. It accepts rules in a Lispy EBNF syntax without indirect
+left recursive rules."
+  :components
+  ((:doc-file "README")
+   (:doc-file "COPYING")
+   (:doc-file ".project")
+   (:module :examples
+	    :components
+	    ((:sample-file "python")
+	     (:sample-file "vs-cobol-ii")))
+   (:module :src
+	    :components
+	    ((:file "package")
+	     (:file "common" :depends-on ("package"))
+	     (:file "define" :depends-on ("package" "common"))
+	     (:file "parser" :depends-on ("package" "common"))))))
diff --git a/third_party/lisp/npg/src/common.lisp b/third_party/lisp/npg/src/common.lisp
new file mode 100644
index 0000000000..8b64f5cc0a
--- /dev/null
+++ b/third_party/lisp/npg/src/common.lisp
@@ -0,0 +1,79 @@
+;;;  common.lisp --- common stuff
+
+;;;  Copyright (C) 2003-2006, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+
+#+cmu (ext:file-comment "$Module: common.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :naive-parser-generator)
+
+(eval-when (:compile-toplevel :load-toplevel)
+  (defstruct grammar
+    rules
+    keywords
+    equal-p)
+
+  (defstruct rule
+    name
+    productions)
+
+  (defstruct (production (:conc-name prod-))
+    tokens
+    (tokens-length 0 :type fixnum)
+    action)
+
+  (defstruct token
+    type		     ; type of token (identifier, number, ...)
+    value				; its actual value
+    position)			     ; line/column in the input stream
+  ) ; eval-when
+
+(defmethod print-object ((obj rule) stream)
+  (format stream "#R(~A)" (rule-name obj)))
+
+(defmethod print-object ((obj production) stream)
+  (format stream "#P(action: ~S)" (prod-action obj)))
+
+(defmethod print-object ((obj token) stream)
+  (format stream "#T:~A=~S" (token-type obj) (token-value obj)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declaim (inline make-rules-table find-rule add-rule))
+
+(defun make-rules-table ()
+  (make-hash-table))
+
+(defun find-rule (rule-name rules)
+  (gethash rule-name rules))
+
+(defun add-rule (rule-name rule rules)
+  (setf (gethash rule-name rules) rule))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declaim (inline make-keywords-table find-keyword add-keyword))
+
+(defun make-keywords-table ()
+   (make-hash-table :test 'equal))
+
+(defun find-keyword (keyword-name keywords)
+  (gethash keyword-name keywords))
+
+(defun add-keyword (keyword keywords)
+  (setf (gethash keyword keywords) t))
diff --git a/third_party/lisp/npg/src/define.lisp b/third_party/lisp/npg/src/define.lisp
new file mode 100644
index 0000000000..f52f0381a2
--- /dev/null
+++ b/third_party/lisp/npg/src/define.lisp
@@ -0,0 +1,408 @@
+;;;  define.lisp --- grammar rules definition
+
+;;;  Copyright (C) 2003-2006, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+
+#+cmu (ext:file-comment "$Module: define.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :naive-parser-generator)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar *smart-default-reduction* t
+  "If true the default reductions take only the non-static tokens -
+those that are not declared as strings in the grammar.")
+
+;; These two are filled with DEFRULE.
+(defvar *rules* (make-rules-table))
+(defvar *keywords* (make-keywords-table))
+
+(defun make-action-arguments (tokens)
+  "Given a list of tokens making up a production, return three values:
+the list of variables for the function reducing this production, those
+that are non static and their unambiguous user-friendly names."
+  (flet ((unique (sym list)
+	   (if (not (assoc sym list))
+	       sym
+	       (loop
+		  for i of-type fixnum from 2
+		  for x = (intern (format nil "~:@(~A~)~A" sym i))
+		  while (assoc x list)
+		  finally (return x)))))
+    (loop
+       for tok in tokens
+       for i of-type fixnum from 1
+       for arg = (intern (format nil "$~A" i) (find-package #.*package*))
+       collect arg into args
+       unless (const-terminal-p tok)
+         collect arg into vars
+         and when (symbolp tok)
+           collect (list (unique tok named-vars) arg) into named-vars
+       when (and (listp tok)
+		 (symbolp (cadr tok)))
+	 collect (list (unique (cadr tok) named-vars) arg) into named-vars
+       finally
+       (return (values args vars named-vars)))))
+
+(defun make-action-function (name tokens action)
+  "Create a function with name NAME, arguments derived from TOKENS and
+body ACTION.  Return it's definition."
+  (let ((function
+	 (multiple-value-bind (args vars named-vars)
+	     (make-action-arguments tokens)
+	   `(lambda ,args
+	      (declare (ignorable ,@args))
+	      (let (($vars (list ,@vars))
+		    ($all (list ,@args))
+		    ,@named-vars
+		    ($alist (list ,@(mapcar #'(lambda (v)
+						`(cons ',(intern (symbol-name (car v)))
+						       ,(cadr v)))
+					    named-vars))))
+		(declare (ignorable $vars $all $alist ,@(mapcar #'car named-vars)))
+		(flet ((make-object (&optional type args)
+			 (apply #'make-instance (or type ',name)
+				(append args $alist))))
+		  ,action))))))
+    (when *compile-print*
+      (if *compile-verbose*
+	  (format t "; Compiling ~S:~%  ~S~%" name function)
+	  (format t "; Compiling ~S~%" name)))
+    (compile name function)))
+
+(defun define-rule (name productions)
+  "Accept a rule in EBNF-like syntax, translate it into a sexp and a
+call to INSERT-RULE-IN-CURRENT-GRAMMAR."
+  (flet ((transform (productions)
+	   (loop
+	      for tok in productions
+	      with prod = nil
+	      with action = nil
+	      with phase = nil
+	      with new-prods = nil
+	      while tok
+	      do (cond ((eq tok :=)
+			(push (list (nreverse prod) action) new-prods)
+			(setf prod nil
+			      action nil
+			      phase :prod))
+		       ((eq tok :reduce)
+			(setf phase :action))
+		       ((eq tok :tag)
+			(setf phase :tag))
+		       ((eq phase :tag)
+			(setf action `(cons ,tok $vars)))
+		       ((eq phase :action)
+			(setf action tok))
+		       ((eq phase :prod)
+			(push tok prod)))
+	      finally
+		(return (cdr (nreverse (cons (list (nreverse prod) action) new-prods)))))))
+    (insert-rule-in-current-grammar name (transform productions))))
+
+(defmacro defrule (name &rest productions)
+  "Wrapper macro for DEFINE-RULE."
+  `(define-rule ',name ',productions))
+
+(defun make-optional-rule (token)
+  "Make a rule for a possibly missing (non)terminal (? syntax) and
+return it."
+  (insert-rule-in-current-grammar
+   (gensym (concatenate 'string "OPT-"
+			(if (rule-p token)
+			    (symbol-name (rule-name token))
+			    (string-upcase token))))
+   `(((,token)) (()))))
+
+(defun make-alternative-rule (tokens)
+  "Make a rule for a list of alternatives (\"or\" syntax) and return it."
+  (insert-rule-in-current-grammar
+   (gensym "ALT")
+   (mapcar #'(lambda (alternative)
+	       `((,alternative)))
+	   tokens)))
+
+(defun make-nonempty-list-rule (token &optional separator)
+  "Make a rule for a non-empty list (+ syntax) and return it."
+  (let ((rule-name (gensym (concatenate 'string "NELST-"
+					(if (rule-p token)
+					    (symbol-name (rule-name token))
+					    (string-upcase token))))))
+    (insert-rule-in-current-grammar
+     rule-name
+     (if separator
+	 `(((,token ,separator ,rule-name)
+	    (cons $1 $3))
+	   ((,token) ,#'list))
+	 `(((,token ,rule-name)
+	    (cons $1 $2))
+	   ((,token) ,#'list))))))
+
+(defun make-list-rule (token &optional separator)
+  "Make a rule for a possibly empty list (* syntax) return it."
+  (make-optional-rule (make-nonempty-list-rule token separator)))
+
+(defun const-terminal-p (object)
+  (or (stringp object)
+      (keywordp object)))
+
+(defun expand-production-token (tok)
+  "Translate token of the type NAME? or NAME* or NAME+ into (? NAME)
+or (* NAME) or (+ NAME).  This is used by the DEFRULE macro."
+  (if (symbolp tok)
+      (let* ((name (symbol-name tok))
+	     (last (char name (1- (length name))))
+	     ;; this looks silly but we need to make sure that we
+	     ;; return symbols interned in this package, no one else
+	     (op (cadr (assoc last '((#\? ?) (#\+ +) (#\* *))))))
+	(if (and (> (length name) 1) op)
+	    (list op
+		  (intern (subseq name 0 (1- (length name)))))
+	    tok))
+      tok))
+
+(defun EBNF-to-SEBNF (tokens)
+  "Take a production as a list of TOKENS and expand it.  This turns a
+EBNF syntax into a sexp-based EBNF syntax or SEBNF."
+  (loop
+     for tok in tokens
+     for token = (expand-production-token tok)
+     with new-tokens = '()
+     do (cond ((member token '(* + ?))
+	       (setf (car new-tokens)
+		     (list token (car new-tokens))))
+	      (t
+	       (push token new-tokens)))
+     finally (return (nreverse new-tokens))))
+
+(defun SEBNF-to-BNF (tokens)
+  "Take a production in SEBNF (Symbolic Extended BNF) syntax and turn
+it into BNF.  The production is simplified but the current grammar is
+populated with additional rules."
+  (flet ((make-complex-token-rule (tok)
+	   (ecase (car tok)
+	     (* (apply #'make-list-rule (cdr tok)))
+	     (+ (apply #'make-nonempty-list-rule (cdr tok)))
+	     (? (make-optional-rule (cadr tok)))
+	     (or (make-alternative-rule (cdr tok))))))
+    (loop
+       for token in tokens
+       with new-tokens = '()
+       with keywords = '()
+       do (cond ((listp token)
+		 (push (make-complex-token-rule token) new-tokens))
+		(t
+		 (push token new-tokens)
+		 (when (const-terminal-p token)
+		   (push token keywords))))
+       finally (return (values (nreverse new-tokens) keywords)))))
+
+(defun make-default-action-function (name tokens)
+  "Create a sexp to be used as default action in case one is not
+supplied in the production.  This is usually a quite sensible
+one.  That is, only the non-constant tokens are returned in a
+list and in case only a variable token is available that one is
+returned (not included in a list).  If all the tokens are
+constant, then all of them are returned in a list."
+  (cond ((null tokens)
+	 ;; if the production matched the empty list (no tokens) we
+	 ;; return always nil, that is the function LIST applied to no
+	 ;; arguments
+	 #'list)
+	((null (cdr tokens))
+	 ;; if the production matches just one token we simply return
+	 ;; that
+	 #'identity)
+	(*smart-default-reduction*
+	 ;; If we are required to be "smart" then create a function
+	 ;; that simply returns the non static tokens of the
+	 ;; production.  If the production doesn't have nonterminal,
+	 ;; then return all the tokens.  If the production has only
+	 ;; one argument then return that one only.
+	 (make-action-function name tokens '(cond
+					     ((null $vars) $all)
+					     ((null (cdr $vars)) (car $vars))
+					     (t $vars))))
+	(t
+	 ;; in all the other cases we return all the token matching
+	 ;; the production
+	 #'list)))
+
+(defun make-production-from-descr (name production-description)
+  "Take a production NAME and its description in the form of a sexp
+and return a production structure object together with a list of used
+keywords."
+  (destructuring-bind (tokens &optional action) production-description
+    (let ((expanded-tokens (EBNF-to-SEBNF tokens)))
+      (multiple-value-bind (production-tokens keywords)
+	  (sebnf-to-bnf expanded-tokens)
+      (let ((funct
+	     (cond ((not action)
+		    (make-default-action-function name expanded-tokens))
+		   ((or (listp action)
+			;; the case when the action is simply to
+			;; return a token (ie $2) or a constant value
+			(symbolp action))
+		    (make-action-function name expanded-tokens action))
+		   ((functionp action)
+		    action)
+		   (t			; action is a constant
+		    #'(lambda (&rest args)
+			(declare (ignore args))
+			action)))))
+	(values
+	 ;; Make a promise instead of actually resolving the
+	 ;; nonterminals.  This avoids endless recursion.
+	 (make-production :tokens production-tokens
+			  :tokens-length (length production-tokens)
+			  :action funct)
+	 keywords))))))
+
+(defun remove-immediate-left-recursivity (rule)
+  "Turn left recursive rules of the type
+    A -> A x | y
+into
+    A -> y A2
+    A2 -> x A2 | E
+where E is the empty production."
+  (let ((name (rule-name rule))
+	(productions (rule-productions rule)))
+    (loop
+       for prod in productions
+       for tokens = (prod-tokens prod)
+       ;; when immediately left recursive
+       when (eq (car tokens) rule)
+       collect prod into left-recursive
+       else
+       collect prod into non-left-recursive
+       finally
+	 ;; found any left recursive production?
+	 (when left-recursive
+	   (warn "rule ~S is left recursive" name)
+	   (let ((new-rule (make-rule :name (gensym "REWRITE"))))
+	     ;; A -> y A2
+	     (setf (rule-productions rule)
+		   (mapcar #'(lambda (p)
+			       (let ((tokens (prod-tokens p))
+				     (action (prod-action p)))
+				 (make-production :tokens (append tokens (list new-rule))
+						  :tokens-length (1+ (prod-tokens-length p))
+						  :action #'(lambda (&rest args)
+							      (let ((f-A2 (car (last args)))
+								    (head (butlast args)))
+								(funcall f-A2 (apply action head)))))))
+			   non-left-recursive))
+	     ;; A2 -> x A2 | E
+	     (setf (rule-productions new-rule)
+		   (append
+		    (mapcar #'(lambda (p)
+				(let ((tokens (prod-tokens p))
+				      (action (prod-action p)))
+				  (make-production :tokens (append (cdr tokens) (list new-rule))
+						   :tokens-length (prod-tokens-length p)
+						   :action #'(lambda (&rest args)
+							       (let ((f-A2 (car (last args)))
+								     (head (butlast args)))
+								 #'(lambda (x)
+								     (funcall f-A2 (apply action x head))))))))
+			    left-recursive)
+		    (list
+		     (make-production :tokens nil
+				      :tokens-length 0
+				      :action #'(lambda () #'(lambda (arg) arg)))))))))))
+
+(defun remove-left-recursivity-from-rules (rules)
+  (loop
+     for rule being each hash-value in rules
+     do
+     ;; More to be done here.  For now only the trivial immediate left
+     ;; recursivity is removed -wcp18/11/03.
+       (remove-immediate-left-recursivity rule)))
+
+(defun resolve-all-nonterminals (rules)
+  (loop
+     for rule being each hash-value in rules
+     do (loop
+	   for production in (rule-productions rule)
+	   do (setf (prod-tokens production)
+		    (resolve-nonterminals (prod-tokens production) rules)))))
+
+(defun make-rule-productions (rule-name production-descriptions)
+  "Return a production object that belongs to RULE-NAME made according
+to PRODUCTION-DESCRIPTIONS.  See also MAKE-PRODUCTION-FROM-DESCR."
+  (loop
+     for descr in production-descriptions
+     for i of-type fixnum from 1 by 1
+     for prod-name = (intern (format nil "~:@(~A~)-PROD~A" rule-name i))
+     with productions = '()
+     with keywords = '()
+     do (progn
+	  (multiple-value-bind (production keyws)
+	      (make-production-from-descr prod-name descr)
+	    (push production productions)
+	    (setf keywords (append keyws keywords))))
+     finally (return
+	       (values (nreverse productions) keywords))))
+
+(defun create-rule (name production-descriptions)
+  "Return a new rule object together with a list of keywords making up
+the production definitions."
+  (multiple-value-bind (productions keywords)
+      (make-rule-productions name production-descriptions)
+    (values (make-rule :name name :productions productions)
+	    keywords)))
+
+(defun insert-rule-in-current-grammar (name productions)
+  "Add rule to the current grammar and its keywords to the keywords
+hash table.  You don't want to use this directly.  See DEFRULE macro
+instead."
+  (when (find-rule name *rules*)
+    (error "redefining rule ~A" name))
+  (multiple-value-bind (rule keywords)
+      (create-rule name productions)
+    (add-rule name rule *rules*)
+    (dolist (term keywords)
+      (add-keyword term *keywords*))
+    rule))
+
+(defun resolve-nonterminals (tokens rules)
+  "Given a list of production tokens, try to expand the nonterminal
+ones with their respective rule from the the RULES pool."
+  (flet ((resolve-symbol (sym)
+	   (or (find-rule sym rules)
+	       sym)))
+    (mapcar #'(lambda (tok)
+		(if (symbolp tok)
+		    (resolve-symbol tok)
+		    tok))
+	    tokens)))
+
+(defun reset-grammar ()
+  "Empty the current grammar from any existing rule."
+  (setf *rules* (make-rules-table)
+	*keywords* (make-keywords-table)))
+
+(defun generate-grammar (&optional (equal-p #'string-equal))
+  "Return a GRAMMAR structure suitable for the PARSE function, using
+the current rules.  EQUAL-P, if present, is a function to be used to
+match the input tokens; it defaults to STRING-EQUAL."
+  (resolve-all-nonterminals *rules*)
+  (remove-left-recursivity-from-rules *rules*)
+  (make-grammar :rules *rules*
+		:keywords *keywords*
+		:equal-p equal-p))
diff --git a/third_party/lisp/npg/src/package.lisp b/third_party/lisp/npg/src/package.lisp
new file mode 100644
index 0000000000..b405f7b5f1
--- /dev/null
+++ b/third_party/lisp/npg/src/package.lisp
@@ -0,0 +1,50 @@
+;;;  package.lisp --- backtracking parser package definition
+
+;;;  Copyright (C) 2003-2006, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+
+#+cmu (ext:file-comment "$Module: package.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :cl-user)
+
+(defpackage :naive-parser-generator
+  (:nicknames :npg)
+  (:use :common-lisp)
+  (:export
+   #:parse				; The Parser
+   #:reset-grammar
+   #:generate-grammar
+   #:print-grammar-figures
+   #:grammar-keyword-p
+   #:keyword
+   #:grammar
+   #:make-token
+   #:token-value
+   #:token-type
+   #:token-position
+   #:later-position
+   #:defrule				; to define grammars
+   #:deftoken				; to define a lexer
+   #:input-cursor-mixin
+   #:copy-input-cursor-slots
+   #:dup-input-cursor
+   #:read-next-tokens
+   #:end-of-input
+   #:? #:+ #:* #:or
+   #:$vars #:$all #:$alist
+   #:$1 #:$2 #:$3 #:$4 #:$5 #:$6 #:$7 #:$8 #:$9 #:$10))
diff --git a/third_party/lisp/npg/src/parser.lisp b/third_party/lisp/npg/src/parser.lisp
new file mode 100644
index 0000000000..328be1dcf3
--- /dev/null
+++ b/third_party/lisp/npg/src/parser.lisp
@@ -0,0 +1,234 @@
+;;;  parser.lisp --- runtime parser
+
+;;;  Copyright (C) 2003-2006, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+
+#+cmu (ext:file-comment "$Module: parser.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+;;;  Commentary:
+;;;
+;;; This is the runtime part of the parser.  The code that is
+;;; responsible to execute the parser defined with the primitives
+;;; found in define.lisp.
+
+(in-package :naive-parser-generator)
+
+(defvar *debug* nil
+  "Either nil or a stream where to write the debug informations.")
+#+debug (declaim (fixnum *maximum-recursion-depth*))
+#+debug (defvar *maximum-recursion-depth* 1000
+  "Maximum depth the parser is allowed to recursively call itself.
+This is the only way for the parser to detect a loop in the grammar.
+Tune this if your grammar is unusually complex.")
+
+(declaim (inline reduce-production))
+(defun reduce-production (production arguments)
+  "Apply PRODUCTION's action on ARGUMENTS.  This has the effect of
+  \"reducing\" the production."
+  (when *debug*
+    (format *debug* "reducing ~S on ~S~%" production arguments))
+  (flet ((safe-token-value (token)
+	   (if (token-p token)
+	       (token-value token)
+	       token)))
+    (apply (prod-action production) (mapcar #'safe-token-value arguments))))
+
+(defgeneric later-position (pos1 pos2)
+  (:documentation
+   "Compare two file postions and return true if POS1 is later than
+POS2 in the input stream."))
+
+;; This is meant to be overloaded in the lexer
+(defmethod later-position ((pos1 integer) (pos2 integer))
+  (> pos1 pos2))
+
+;; this looks silly but turns out to be useful (see below)
+(defmethod later-position (pos1 pos2)
+  (and (eq pos1 :eof) (not (eq pos2 :eof))))
+
+(defgeneric read-next-tokens (tokens-source)
+  (:documentation "Read next token from a lexical analysed stream.  The nature of
+TOKENS-SOURCE is implementation dependent and any lexical analyzer is
+supposed to specialise this method."))
+
+;; This is the actual parser.  the algorithm is pretty
+;; straightforward, the execution of the reductions a bit less.  Error
+;; recovery is rather clumsy.
+
+(defun parse (grammar start tokenizer)
+  "Match a GRAMMAR against the list of input tokens coming from TOKENIZER.
+Return the reduced values according to the nonterminal actions.  Raise
+an error on failure."
+  (declare (type grammar grammar)
+	   (type symbol start))
+  (labels
+      ((match-token (expected token)
+	 (when *debug*
+	   (format *debug* "match-token ~S ~S -> " expected token))
+	 (let ((res (cond ((symbolp expected)
+			   ;; non-costant terminal (like identifiers)
+			   (eq expected (token-type token)))
+			  ((and (stringp expected)
+				(stringp (token-value token)))
+			   ;; string costant terminal
+			   (funcall (the function (grammar-equal-p grammar)) expected (token-value token)))
+			  ((functionp expected)
+			   ;; custom equality predicate (must be able
+			   ;; to deal with token objects)
+			   (funcall expected token))
+			  ;; all the rest
+			  (t (equal expected (token-value token))))))
+	   (when *debug*
+	     (format *debug* "~Amatched~%" (if res "" "not ")))
+	   res))
+       (match (expected matched #+debug depth)
+	 (declare (list expected matched)
+		  #+debug (fixnum depth))
+	 (let ((first-expected (car expected)))
+	   (cond #+debug ((> depth *maximum-recursion-depth*)
+		  (error "endless recursion on ~A ~A at ~A expecting ~S"
+			 (token-type (car matched)) (token-value (car matched))
+			 (token-position (car matched)) expected))
+		 ((eq first-expected :any)
+		  (match (cdr expected) (cdr matched) #+debug depth))
+		 ;; This is a trick to obtain partial parses.  When we
+		 ;; reach this expected token we assume we succeeded
+		 ;; the parsing and return the remaining tokens as
+		 ;; part of the match.
+		 ((eq first-expected :rest)
+		  ;; we could be at the end of input so we check this
+		  (unless (cdr matched)
+		    (setf (cdr matched) (list :rest)))
+		  (list nil nil))
+		 ((rule-p first-expected)
+		  ;; If it's a rule, then we try to match all its
+		  ;; productions.  We return the first that succeeds.
+		  (loop
+		     for production in (rule-productions first-expected)
+		     for production-tokens of-type list = (prod-tokens production)
+		     with last-error-position = nil
+		     with last-error = nil
+		     for (error-position error-descr) =
+		       (progn
+			 (when *debug*
+			   (format *debug* "trying to match ~A: ~S~%"
+				   (rule-name first-expected) production-tokens))
+			 (match (append production-tokens (cdr expected)) matched #+debug (1+ depth)))
+		     do (cond ((not error-position)
+			       (return (let ((args-count (prod-tokens-length production)))
+					 (setf (cdr matched)
+					       (cons (reduce-production
+						      production
+						      (subseq (the list (cdr matched)) 0 args-count))
+						     (nthcdr (1+ args-count) matched)))
+					 (list nil nil))))
+			      ((or (not last-error)
+				   (later-position error-position last-error-position))
+			       (setf last-error-position error-position
+				     last-error error-descr)))
+		     ;; if everything fails return the "best" error
+		     finally (return (list last-error-position
+					   (if *debug*
+					       #'(lambda ()
+						   (format nil "~A, trying to match ~A"
+							   (funcall (the function last-error))
+							   (rule-name first-expected)))
+					       last-error)))))
+		 (t
+		  ;; if necessary load the next tokens
+		  (when (null (cdr matched))
+		    (setf (cdr matched) (read-next-tokens tokenizer)))
+		  (cond ((and (or (null expected) (eq first-expected :eof))
+			      (null (cdr matched)))
+			 ;; This point is reached only once for each complete
+			 ;; parsing.  The expected tokens and the input
+			 ;; tokens have been exhausted at the same time.
+			 ;; Hence we succeeded the parsing.
+			 (setf (cdr matched) (list :eof))
+			 (list nil nil))
+			((null expected)
+			 ;; Garbage at end of parsing.  This may mean that we
+			 ;; have considered a production completed too soon.
+			 (list (token-position (car matched))
+			       #'(lambda ()
+				   "garbage at end of parsing")))
+			((null (cdr matched))
+			 ;; EOF error
+			 (list :eof
+			       #'(lambda ()
+				   (format nil "end of input expecting ~S" expected))))
+			(t ;; normal token
+			 (let ((first-token (cadr matched)))
+			   (if (match-token first-expected first-token)
+			       (match (cdr expected) (cdr matched) #+debug depth)
+			       ;; failed: we return the error
+			       (list (token-position first-token)
+				     #'(lambda ()
+					 (format nil "expected ~S but got ~S ~S"
+						 first-expected (token-type first-token)
+						 (token-value first-token)))))))))))))
+    (declare (inline match-token))
+    (let ((result (list :head)))
+      (destructuring-bind (error-position error)
+	  (match (list (find-rule start (grammar-rules grammar))) result #+debug 0)
+	(when error-position
+	  (error "~A at ~A~%" (funcall (the function error)) error-position))
+	(cadr result)))))
+
+(defgeneric terminals-in-grammar (grammar-or-hashtable)
+  (:documentation
+   "Find non constant terminal symbols in GRAMMAR."))
+
+(defmethod terminals-in-grammar ((grammar hash-table))
+  (loop
+     for rule being each hash-value of grammar
+     with terminals = '()
+     do (loop
+	   for prod in (rule-productions rule)
+	   do (loop
+		 for tok in (prod-tokens prod)
+		 when (symbolp tok)
+		 do (pushnew tok terminals)))
+     finally (return terminals)))
+
+(defmethod terminals-in-grammar ((grammar grammar))
+  (terminals-in-grammar (grammar-rules grammar)))
+
+(defun print-grammar-figures (grammar &optional (stream *standard-output*))
+  (format stream "rules: ~A~%constant terminals: ~A~%variable terminals: ~S~%"
+	  (hash-table-count (grammar-rules grammar))
+	  (hash-table-count (grammar-keywords grammar))
+	  (terminals-in-grammar (grammar-rules grammar))))
+
+
+(defun grammar-keyword-p (keyword grammar)
+  "Check if KEYWORD is part of this grammar."
+  (find-keyword keyword (grammar-keywords grammar)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar *grammars* (make-hash-table))
+
+(defun find-grammar (name)
+  (gethash name *grammars*))
+
+(defun delete-grammar (name)
+  (remhash name *grammars*))
+
+(defun add-grammar (name grammar)
+  (setf (gethash name *grammars*) grammar))