diff options
Diffstat (limited to 'third_party/lisp/npg')
| -rw-r--r-- | third_party/lisp/npg/.project | 1 | ||||
| -rw-r--r-- | third_party/lisp/npg/.skip-subtree | 1 | ||||
| -rw-r--r-- | third_party/lisp/npg/COPYING | 504 | ||||
| -rw-r--r-- | third_party/lisp/npg/OWNERS | 1 | ||||
| -rw-r--r-- | third_party/lisp/npg/README | 48 | ||||
| -rw-r--r-- | third_party/lisp/npg/default.nix | 14 | ||||
| -rw-r--r-- | third_party/lisp/npg/examples/python.lisp | 336 | ||||
| -rw-r--r-- | third_party/lisp/npg/examples/vs-cobol-ii.lisp | 1901 | ||||
| -rw-r--r-- | third_party/lisp/npg/npg.asd | 55 | ||||
| -rw-r--r-- | third_party/lisp/npg/src/common.lisp | 79 | ||||
| -rw-r--r-- | third_party/lisp/npg/src/define.lisp | 408 | ||||
| -rw-r--r-- | third_party/lisp/npg/src/package.lisp | 50 | ||||
| -rw-r--r-- | third_party/lisp/npg/src/parser.lisp | 234 |
13 files changed, 3632 insertions, 0 deletions
diff --git a/third_party/lisp/npg/.project b/third_party/lisp/npg/.project new file mode 100644 index 000000000000..82a8fe48bbfb --- /dev/null +++ b/third_party/lisp/npg/.project @@ -0,0 +1 @@ +NPG a Naive Parser Generator diff --git a/third_party/lisp/npg/.skip-subtree b/third_party/lisp/npg/.skip-subtree new file mode 100644 index 000000000000..5051f60d6b86 --- /dev/null +++ b/third_party/lisp/npg/.skip-subtree @@ -0,0 +1 @@ +prevent readTree from creating entries for subdirs that don't contain an .nix files diff --git a/third_party/lisp/npg/COPYING b/third_party/lisp/npg/COPYING new file mode 100644 index 000000000000..223ede7de3ec --- /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/OWNERS b/third_party/lisp/npg/OWNERS new file mode 100644 index 000000000000..2e9580706346 --- /dev/null +++ b/third_party/lisp/npg/OWNERS @@ -0,0 +1 @@ +sterni diff --git a/third_party/lisp/npg/README b/third_party/lisp/npg/README new file mode 100644 index 000000000000..a1661e744a37 --- /dev/null +++ b/third_party/lisp/npg/README @@ -0,0 +1,48 @@ + + NPG a Naive Parser Generator + for Common Lisp + + Copyright (C) 2003-2006, 2010 by Walter C. Pelissero + Copyright (C) 2021 by the TVL Authors + +Vendored into depot as it is a dependency of mime4cl and upstream has +become inactive. Upstream and depot version may diverge. + +Upstream Website: http://wcp.sdf-eu.org/software/#npg +Vendored Tarball: http://wcp.sdf-eu.org/software/npg-20150517T144652.tbz + +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 and nix file are provided. + +See the examples directory for clues on how to use it. diff --git a/third_party/lisp/npg/default.nix b/third_party/lisp/npg/default.nix new file mode 100644 index 000000000000..af7ec53eaf93 --- /dev/null +++ b/third_party/lisp/npg/default.nix @@ -0,0 +1,14 @@ +# Copyright (C) 2021 by the TVL Authors +# SPDX-License-Identifier: LGPL-2.1-or-later +{ depot, pkgs, ... }: + +depot.nix.buildLisp.library { + name = "npg"; + + srcs = [ + ./src/package.lisp + ./src/common.lisp + ./src/define.lisp + ./src/parser.lisp + ]; +} diff --git a/third_party/lisp/npg/examples/python.lisp b/third_party/lisp/npg/examples/python.lisp new file mode 100644 index 000000000000..a45ac614f716 --- /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 000000000000..9ebd45a169ce --- /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 000000000000..1e35186d6c8c --- /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 000000000000..8b64f5cc0a7b --- /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 000000000000..783f071fc5d9 --- /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 000000000000..b405f7b5f19e --- /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 000000000000..c15d26fe394e --- /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)) |