diff --git a/LICENSE-LGPL b/LICENSE-LGPL new file mode 100644 --- /dev/null +++ b/LICENSE-LGPL @@ -0,0 +1,507 @@ + 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. + + + Copyright (C) + + 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 + +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. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,14 @@ +Implementation of the LDTA tool challenge using murder and AspectAG. +For more information about the challenge consult its web page: http://ldta.info/tool.html + +To build an artifact, flags indicating the corresponding language and task have to be passed. +Existing options are: + - languages: l1, l2, l3 and l4 + - tasks: t1, t2, t3 and t5 + +For example, to build Artifact 5: + +runghc Setup.hs configure --flags="l4 t5" +runghc Setup.hs build + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ + +import Distribution.Simple +main = defaultMain diff --git a/example/const.ob b/example/const.ob new file mode 100644 --- /dev/null +++ b/example/const.ob @@ -0,0 +1,3 @@ +MODULE hola; +CONST X = (2); +END chau. diff --git a/example/prog1.ob b/example/prog1.ob new file mode 100644 --- /dev/null +++ b/example/prog1.ob @@ -0,0 +1,23 @@ +MODULE hola; +CONST X = (2 >= + 3 - 4 + 6); Y = (1 # -4) - 3; Z = 2 + x; + C1 = 23 + 2; C2 = C1 DIV 0; +TYPE tipo = INTEGER; X = BOOLEAN; +VAR xx, jj, xx : tipo; aa, xx: tipo; + bvar : BOOLEAN; +BEGIN + jj := 3 MOD 0; + bvar := TRUE; + jj := jj + 1 - X + y; + WHILE 2 < ~3 DO + xx := (5 MOD 2) * TRUE; + xx := xx + Z + END; + IF TODO THEN + X := aa DIV (2 - 2) + ELSIF jj > bvar THEN + jj := 2 + tipo + 9; + jj := jj * TRUE + ELSE + jj := + 2 & 4 + END +END chau. diff --git a/example/prog1ok.ob b/example/prog1ok.ob new file mode 100644 --- /dev/null +++ b/example/prog1ok.ob @@ -0,0 +1,27 @@ +MODULE prog1; +CONST X = 10 + 2; +TYPE tipo = INTEGER; + tipo2 = tipo; + tipo3 = BOOLEAN; +VAR x, y : tipo; z: tipo2; + b : tipo3; + i : INTEGER; +BEGIN + x := 1; + y := 10; + z := 5; + i := 9 + 2; + WHILE x < X DO + x := x + 1; + y := y + z + END; + b := y >= (x * z); + IF b THEN + x := 1 + ELSIF x > 10 THEN + x := z * 3 + ELSE + x := x + 1 + END; + b := FALSE +END prog1. diff --git a/example/prog2.ob b/example/prog2.ob new file mode 100644 --- /dev/null +++ b/example/prog2.ob @@ -0,0 +1,29 @@ +MODULE hola; +CONST X = (2 >= + 3); Y = (1 # -4) - 3; Z = 2 + x; + W = W + 1; +TYPE tipo = INTEGER; + maltipo = X; + Y = INTEGER; +VAR xx, jj : tipo; aa: tipo; + i : INTEGER; +BEGIN + jj := jj = 3; + jj := jj + 1 - X + y; + CASE xx OF + jj : jj := 3; xx := 2 | + 4 .. X : jj := 10 + ELSE aa := 5 + END; + WHILE 2 < ~4 DO xx := (5 MOD 2) * tipo END; + FOR Z := 4 TO 5 BY 6 DO + IF (jj = TODO) THEN X := aa ELSE jj := + 2 & 4 END + END; + FOR i := i TO 5 BY (6 + i) DO + xx := xx + i; + END; + CASE xx OF + xx : jj := 3 + ELSE jj := 5 + END + +END chau. diff --git a/example/prog2ok.ob b/example/prog2ok.ob new file mode 100644 --- /dev/null +++ b/example/prog2ok.ob @@ -0,0 +1,22 @@ +MODULE prog2; +CONST X = 1; + Y = 2; +TYPE tipo = INTEGER; +VAR x, y, j : tipo; b: BOOLEAN; +BEGIN + b := X = 3; + x := 2; + CASE x OF + X,2,10 : j := 0 | + Y .. 10 : j := 1 + ELSE j := 10 + END; + WHILE j < 10 DO + j := j+1; + b := ~b + END; + y := 0; + FOR x := 1 TO j DO + y := y + x * Y + END +END prog2. diff --git a/example/prog3.ob b/example/prog3.ob new file mode 100644 --- /dev/null +++ b/example/prog3.ob @@ -0,0 +1,48 @@ +MODULE hola; +CONST X = (2 >= + 3); Y = (1 # -4) - 3; Z = 2 + x; + W = W + 1; +TYPE tipo = INTEGER; + maltipo = X; + Y = INTEGER; +VAR xx, jj : tipo; aa: tipo; y : INTEGER; +PROCEDURE Read ( VAR var1 : INTEGER; var2, var3 : X ); +BEGIN + jj := 23 + z +END tipo; +PROCEDURE bueno ( VAR var1 : INTEGER; var2, var3 : BOOLEAN ); +VAR jj : INTEGER; +BEGIN + jj := 23; + IF var2 THEN + var1 := jj + ELSIF var3 THEN + var1 := var2 + 1 + ELSE + var1 := 0 + END +END tipo; + +BEGIN + jj := jj + Write + 1 - X + y; + WHILE 2 < ~3 DO xx := (5 MOD 2) * tipo END; + bueno (jj, 2 > 3, 2 < 3); + bueno (3); + bueno (jj, 2 > 3, 2 < 3, jj); + malo (34); + Read (y); + Read (xx); + Read (23); + Write (23); + Write (xx); + Write (y,9); + WriteLn(2); + WriteLn; + X; + FOR Z := 4 TO 5 BY 6 DO + IF TODO THEN + X := aa + ELSE + jj := + 2 & 4 + END + END +END hola. diff --git a/example/prog3ok.ob b/example/prog3ok.ob new file mode 100644 --- /dev/null +++ b/example/prog3ok.ob @@ -0,0 +1,37 @@ +MODULE hola; +CONST X = 10; +TYPE tipo = INTEGER; +VAR x: tipo; b : BOOLEAN; + +PROCEDURE Proc1 ( VAR var1 : INTEGER; var2, var3 : tipo ); +VAR x : INTEGER; +PROCEDURE Proc11; +BEGIN + x := X +END Proc11; + +BEGIN + Proc11; + var1 := var2 + var3 + x; + Write(var1); WriteLn +END Proc1; + + +PROCEDURE Proc2 ( VAR var1 : INTEGER; var2, var3 : BOOLEAN ); +VAR x : INTEGER; +BEGIN + x := 23; + IF var2 THEN + var1 := x + ELSIF var3 THEN + var1 := x + 1 + ELSE + var1 := 0 + END +END Proc2; + +BEGIN + Proc1(x,2,3); + Proc2(x,b,2>3); + Write(x); WriteLn +END hola. diff --git a/example/prog4.ob b/example/prog4.ob new file mode 100644 --- /dev/null +++ b/example/prog4.ob @@ -0,0 +1,53 @@ +MODULE hola; +CONST X = (2 >= + 3); Y = (1 # -4) - 3; Z = 2 + x; + W = W + 1; +TYPE tipo = INTEGER; + maltipo = X; + Y = INTEGER; + matrix = ARRAY 10 OF ARRAY 5 OF INTEGER; + rec = RECORD f1 : INTEGER; f2 : ARRAY 3 OF INTEGER; f1 : BOOLEAN END; +VAR xx, jj : tipo; aa: tipo; + r1 : RECORD f1 : INTEGER; f2 : ARRAY 3 OF INTEGER; f1 : BOOLEAN END; + a1, a2 : ARRAY 5 OF INTEGER; + b1 : BOOLEAN; + m1 : matrix; +PROCEDURE tipo ( VAR var1 : INTEGER; var2, var3 : X ); +BEGIN + jj := 23 + z +END tipo; +PROCEDURE bueno ( VAR var1 : INTEGER; var2, var3 : BOOLEAN ); +VAR jj : INTEGER; +BEGIN + jj := 23; + IF var2 THEN + var1 := jj + ELSIF var3 THEN + var1 := var2 + 1 + ELSE + var1 := 0 + END +END tipo; + +BEGIN + f[0] := 1; tipo.f1 := 2; + jj := jj + 1 - X + y; + jj := r1.f1 + a1.f1 - jj[10] * r1.f3; + WHILE 2 < ~3 DO xx := (5 MOD 2) * tipo END; + bueno (jj, 2 > 3, 2 < 3); + bueno (r1,m1); + bueno (jj, 2 > 3, 2 < 3, jj); + malo (34); + X; + a1[2] := 4 < 5; + m1[1] := a2; + b1 := m1[0][0]; + a1 := a2; + r1.f1[1] := m1[0][1]; + FOR Z := 4 TO 5 BY 6 DO + IF TODO THEN + X := aa + ELSE + jj := + 2 & 4 + END + END +END hola. diff --git a/example/prog4ok.c b/example/prog4ok.c new file mode 100644 --- /dev/null +++ b/example/prog4ok.c @@ -0,0 +1,51 @@ +typedef int _hola_matrix[10][10]; +typedef struct { + int f1; int f2[3]; + } _hola_rec; +int _hola_0case; +int _hola_a1[5]; +_hola_rec _hola_r1; +_hola_matrix _hola_m1; +int _hola_i, _hola_j; +void _hola_start(_hola_matrix (*_hola_1start_m)) +{ + int _hola_1start_0case; + int _hola_1start_i, _hola_1start_j; + _hola_1start_i = 0; + while (_hola_1start_i <= 9) + { + _hola_1start_j = 0; + while (_hola_1start_j <= 9) + { + (*_hola_1start_m)[_hola_1start_i][_hola_1start_j] = _hola_1start_i * _hola_1start_j; + ; + _hola_1start_j = _hola_1start_j + 1; + } + ; + _hola_1start_i = _hola_1start_i + 1; + } + ; +} +int main() +{ + _hola_a1[0] = 10; + _hola_r1.f1 = 9; + _hola_r1.f2[0] = 8; + _hola_start(&_hola_m1); + _hola_i = 0; + while (_hola_i <= 9) + { + _hola_j = 0; + while (_hola_j <= 9) + { + printf("%d", _hola_m1[_hola_i][_hola_j]); + ; + _hola_j = _hola_j + 1; + } + printf("\n"); + ; + _hola_i = _hola_i + 1; + } + ; + return 0; +} diff --git a/example/prog4ok.ob b/example/prog4ok.ob new file mode 100644 --- /dev/null +++ b/example/prog4ok.ob @@ -0,0 +1,35 @@ +MODULE hola; +TYPE matrix = ARRAY 10 OF ARRAY 10 OF INTEGER; + rec = RECORD + f1 : INTEGER; + f2 : ARRAY 3 OF INTEGER + END; + +VAR a1 : ARRAY 5 OF INTEGER; + r1 : rec; + m1 : matrix; + i,j : INTEGER; + +PROCEDURE start ( VAR m : matrix ); +VAR i,j : INTEGER; +BEGIN + FOR i := 0 TO 9 DO + FOR j := 0 TO 9 DO + m[i][j] := i * j + END + END +END start; + +BEGIN + a1[0] := 10; + r1.f1 := 9; + r1.f2[0] := 8; + start ( m1 ); + FOR i := 0 TO 9 DO + FOR j := 0 TO 9 DO + Write (m1[i][j]) + END; + WriteLn + END + +END hola. diff --git a/example/rec.ob b/example/rec.ob new file mode 100644 --- /dev/null +++ b/example/rec.ob @@ -0,0 +1,19 @@ +MODULE Rec; +VAR g : INTEGER; + +PROCEDURE Proc; +VAR x : INTEGER; +BEGIN + x := 0; + IF g = 0 THEN + g := 1; + Proc + END; + x := x + 1; + Write(x);WriteLn +END Proc; + +BEGIN + g := 0; + Proc +END Rec. diff --git a/oberon0.cabal b/oberon0.cabal new file mode 100644 --- /dev/null +++ b/oberon0.cabal @@ -0,0 +1,360 @@ +cabal-version: >= 1.8 +build-type: Custom +name: oberon0 +version: 0.0.1 +license: LGPL +license-file: LICENSE-LGPL +maintainer: Marcos Viera +description: Oberon0 compiler (from LDTA 2011 challenge) implementation using CoCoCo +homepage: http://www.cs.uu.nl/wiki/Center/CoCoCo +synopsis: Oberon0 Compiler +category: Language +stability: Experimental +author: Marcos Viera +tested-with: GHC >= 7.4.1 + +Flag l1 + description: Oberon-0 + default: False + +Flag l2 + description: l1 + FOR + CASE + default: False + +Flag l3 + description: l2 + procedures + default: False + +Flag l4 + description: l3 + arrays and records + default: False + +Flag t1 + description: pretty-printing + default: False + +Flag t2 + description: with errors + default: False + +Flag t3 + description: type-checking + default: False + +Flag t5 + description: code generation + default: False + + + +library + build-depends: base >= 4, base < 5, ghc-prim >= 0.2.0.0, template-haskell + build-depends: containers >= 0.4, transformers >= 0.2.2.0, mtl >= 2.0.1.0, array >= 0.3.0.3 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: murder >= 1.2 + build-depends: AspectAG >= 0.3.6.1 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + ghc-options: -fcontext-stack=1000 + hs-source-dirs: src + + if flag(t1) || flag(t2) || flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.MainT1 + + if flag(t2) || flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.MainT2 + + if flag(t5) + exposed-modules: Language.Oberon0.MainT5 + build-depends: language-c >= 0.4.2 + + if flag(l1) || flag(l2) || flag(l3) || flag(l4) + exposed-modules: Language.Oberon0.L1.Decl, Language.Oberon0.L1.Gram + if flag(t1) || flag(t2) || flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.L1.SemT1 + if flag(t2) || flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.L1.SemT2 + if flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.L1.SemT3 + if flag(t5) + exposed-modules: Language.Oberon0.L1.SemT5 + + if flag(l2) || flag(l3) || flag(l4) + exposed-modules: Language.Oberon0.L2.Decl, Language.Oberon0.L2.Gram + if flag(t1) || flag(t2) || flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.L2.SemT1 + if flag(t2) || flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.L2.SemT2 + if flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.L2.SemT3 + if flag(t5) + exposed-modules: Language.Oberon0.L2.SemT5 + + if flag(l3) || flag(l4) + exposed-modules: Language.Oberon0.L3.Decl, Language.Oberon0.L3.Gram + if flag(t1) || flag(t2) || flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.L3.SemT1 + if flag(t2) || flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.L3.SemT2 + if flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.L3.SemT3 + if flag(t5) + exposed-modules: Language.Oberon0.L3.SemT5 + + if flag(l4) + exposed-modules: Language.Oberon0.L4.Decl, Language.Oberon0.L4.Gram + if flag(t1) || flag(t2) || flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.L4.SemT1 + if flag(t2) || flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.L4.SemT2 + if flag(t3) || flag(t5) + exposed-modules: Language.Oberon0.L4.SemT3 + if flag(t5) + exposed-modules: Language.Oberon0.L4.SemT5 + + + +executable l1t1 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L1/T1.hs + if !(flag(l1) && flag(t1)) + buildable: False + + +executable l1t2 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: containers >= 0.4 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L1/T2.hs + if !(flag(l1) && flag(t2)) + buildable: False + + +executable l1t3 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: containers >= 0.4 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L1/T3.hs + if !(flag(l1) && flag(t3)) + buildable: False + + +executable l1t5 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: containers >= 0.4 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + build-depends: language-c >= 0.4.2 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L1/T5.hs + if !(flag(l1) && flag(t5)) + buildable: False + + + + +executable l2t1 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L2/T1.hs + if !(flag(l2) && flag(t1)) + buildable: False + + +executable l2t2 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: containers >= 0.4 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L2/T2.hs + if !(flag(l2) && flag(t2)) + buildable: False + +executable l2t3 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: containers >= 0.4 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L2/T3.hs + if !(flag(l2) && flag(t3)) + buildable: False + + +executable l2t5 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: containers >= 0.4 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + build-depends: language-c >= 0.4.2 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L2/T5.hs + if !(flag(l2) && flag(t5)) + buildable: False + + + +executable l3t1 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L3/T1.hs + if !(flag(l3) && flag(t1)) + buildable: False + +executable l3t2 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: containers >= 0.4 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L3/T2.hs + if !(flag(l3) && flag(t2)) + buildable: False + +executable l3t3 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: containers >= 0.4 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L3/T3.hs + if !(flag(l3) && flag(t3)) + buildable: False + + +executable l3t5 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: containers >= 0.4 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + build-depends: language-c >= 0.4.2 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L3/T5.hs + if !(flag(l3) && flag(t5)) + buildable: False + + + + + +executable l4t1 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L4/T1.hs + if !(flag(l4) && flag(t1)) + buildable: False + + + +executable l4t2 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: containers >= 0.4 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L4/T2.hs + if !(flag(l4) && flag(t2)) + buildable: False + + +executable l4t3 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: containers >= 0.4 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L4/T3.hs + if !(flag(l4) && flag(t3)) + buildable: False + + +executable l4t5 + build-depends: oberon0 + build-depends: base >= 4, base < 5 + build-depends: containers >= 0.4 + build-depends: AspectAG >= 0.3.6.1 + build-depends: murder >= 1.2 + build-depends: uulib >= 0.9.14, uu-parsinglib >= 2.7.3.4 + build-depends: HList >= 0.2.3 + build-depends: language-c >= 0.4.2 + extensions: TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, Arrows, DoRec, + TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + main-is: src/Language/Oberon0/L4/T5.hs + if !(flag(l4) && flag(t5)) + buildable: False + diff --git a/src/Language/Oberon0/L1/Decl.hs b/src/Language/Oberon0/L1/Decl.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L1/Decl.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-} + +module Language.Oberon0.L1.Decl where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive + +---- L1 Grammar +data Module + = Module { idbgn_Module :: String, decls_Module :: Declarations, stmts_Module :: Statement, idend_Module :: String } + + +data Declarations + = Declarations { cstdecl_Declarations :: DeclL, typdecl_Declarations :: DeclL, vardecl_Declarations :: DeclL } + + +type DeclL = [ Decl ] + +data Decl + = CstDecl { id_CstDecl :: String, exp_CstDecl :: Expression } + | TypDecl { id_TypDecl :: String, typ_TypDecl :: Type } + | VarDecl { idl_VarDecl :: IdentL, typ_VarDecl :: Type } + +data Type + = Type { id_Type :: String } + + +data Statement + = AssigStmt { id_AssigStmt :: String, exp_AssigStmt :: Expression } + | IfStmt { if_IfStmt :: CondStmt, elsif_IfStmt :: CondStmtL, else_IfStmt :: MaybeElseStmt } + | WhileStmt { exp_WhileStmt :: Expression, ss_WhileStmt :: Statement } + | SeqStmt { s1_SeqStmt :: Statement, s2_SeqStmt :: Statement } + | EmptyStmt + + +type CondStmtL = [ CondStmt ] + +data CondStmt + = CondStmt { exp_CondStmt :: Expression, ss_CondStmt :: Statement } + +type MaybeElseStmt = Maybe Statement + + +type IdentL = [ String ] + +type GHC_IntCmp = IntCmp; data IntCmp = ECmp | NECmp | LCmp | LECmp | GCmp | GECmp deriving Eq +type GHC_IntBOp = IntBOp; data IntBOp = Plus | Minus | Times | Div | Mod deriving Eq +type GHC_IntUOp = IntUOp; data IntUOp = Ng | Ps deriving Eq + + +type GHC_BoolBOp = BoolBOp; data BoolBOp = Or | And deriving Eq +type GHC_BoolUOp = BoolUOp; data BoolUOp = Not deriving Eq + +data Expression + = IntCmpExp { op_IntCmpExp :: GHC_IntCmp, e1_IntCmpExp :: Expression, e2_IntCmpExp :: Expression } + | IntBOpExp { op_IntBOpExp :: GHC_IntBOp, e1_IntBOpExp :: Expression, e2_IntBOpExp :: Expression } + | IntUOpExp { op_IntUOpExp :: GHC_IntUOp, e_IntUOpExp :: Expression } + + | BoolBOpExp { op_BoolBOpExp :: GHC_BoolBOp, e1_BoolBOpExp :: Expression, e2_BoolBOpExp :: Expression } + | BoolUOpExp { op_BoolUOpExp :: GHC_BoolUOp, e_BoolUOpExp :: Expression } + + | IdExp { id_IdExp :: String } + | IntExp { int_IntExp :: Int } + | BoolExp { bool_BoolExp :: Bool } + | ParExp { e_ParExp :: Expression } + + +$(deriveAG ''Module) + +$(addNT "Ident") +$(addNT "StatementSequence") + +$(deriveLang "L1" [''Module, ''Declarations, ''DeclL, ''Decl, ''Type, ''Statement, ''CondStmtL, ''CondStmt, ''MaybeElseStmt, ''Expression, ''IdentL]) + diff --git a/src/Language/Oberon0/L1/Gram.hs b/src/Language/Oberon0/L1/Gram.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L1/Gram.hs @@ -0,0 +1,126 @@ +{-# OPTIONS -fcontext-stack=100 #-} + +{-# LANGUAGE Arrows, DoRec, TemplateHaskell #-} + +module Language.Oberon0.L1.Gram where + + +import Language.Oberon0.L1.Decl + +import Control.Arrow +import Control.Applicative +import Data.Set (fromList) + +import Language.Grammars.Murder +import Language.Grammars.Murder.Derive +import Language.Grammars.Grammar +import Language.Grammars.AspectAG + +$(csLabels [ "cs_Module", "cs_Declarations", "cs_Expression", "cs_Factor", "cs_StatementSequence" + , "cs_Statement", "cs_Ident", "cs_IdentL", "cs_MaybeElseStmt", "cs_Type"]) + + +eExp sf = pIntCmpExp sf (sem_Lit ECmp) +neExp sf = pIntCmpExp sf (sem_Lit NECmp) +lExp sf = pIntCmpExp sf (sem_Lit LCmp) +leExp sf = pIntCmpExp sf (sem_Lit LECmp) +gExp sf = pIntCmpExp sf (sem_Lit GCmp) +geExp sf = pIntCmpExp sf (sem_Lit GECmp) + +plusExp sf = pIntBOpExp sf (sem_Lit Plus) +minusExp sf = pIntBOpExp sf (sem_Lit Minus) +timesExp sf = pIntBOpExp sf (sem_Lit Times) +divExp sf = pIntBOpExp sf (sem_Lit Div) +modExp sf = pIntBOpExp sf (sem_Lit Mod) + + +posExp sf = pIntUOpExp sf (sem_Lit Ps) +negExp sf = pIntUOpExp sf (sem_Lit Ng) + + +orExp sf = pBoolBOpExp sf (sem_Lit Or) +andExp sf = pBoolBOpExp sf (sem_Lit And) + +notExp sf = pBoolUOpExp sf (sem_Lit Not) + +trueExp sf t = pBoolExp sf (\r -> DTerm (pos (t r)) True) +falseExp sf f = pBoolExp sf (\r -> DTerm (pos (f r)) False) + +l1 sf = proc () -> do + + rec + + modul <- addNT -< iI (pModule sf) "MODULE" ident ";" + decls + (pMaybe (pEmptyStmt sf, id) (iI "BEGIN" ss Ii)) + "END" ident "." Ii + + decls <- addNT -< iI (pDeclarations sf) + (pMaybe (pDeclL_Nil sf, id) (iI "CONST" cstDeclL Ii)) + (pMaybe (pDeclL_Nil sf, id) (iI "TYPE" typDeclL Ii)) + (pMaybe (pDeclL_Nil sf, id) (iI "VAR" varDeclL Ii)) + Ii + + cstDeclL <- addNT -< pFoldr (pDeclL_Cons sf, pDeclL_Nil sf) (iI (pCstDecl sf) ident "=" exp ";" Ii) + + typDeclL <- addNT -< pFoldr (pDeclL_Cons sf, pDeclL_Nil sf) (iI (pTypDecl sf) ident "=" typ ";" Ii) + + varDeclL <- addNT -< pFoldr (pDeclL_Cons sf, pDeclL_Nil sf) (iI (pVarDecl sf) idL ":" typ ";" Ii) + + idL <- addNT -< iI (pIdentL_Cons sf) ident (pFoldr (pIdentL_Cons sf, pIdentL_Nil sf) (iI "," ident Ii)) Ii + + typ <- addNT -< iI (pType sf) ident Ii + + + exp <- addNT -< iI sexp Ii <|> + iI (eExp sf) exp "=" sexp Ii <|> iI (neExp sf) exp "#" sexp Ii <|> + iI (lExp sf) exp "<" sexp Ii <|> iI (leExp sf) exp "<" "=" sexp Ii <|> + iI (gExp sf) exp ">" sexp Ii <|> iI (geExp sf) exp ">" "=" sexp Ii + + + sexp <- addNT -< iI signed Ii <|> + iI (plusExp sf) sexp "+" signed Ii <|> iI (minusExp sf) sexp "-" signed Ii <|> + iI (orExp sf) sexp "OR" signed Ii + + signed <- addNT -< iI (posExp sf) "+" term Ii <|> iI (negExp sf) "-" term Ii <|> iI term Ii + + + term <- addNT -< iI factor Ii <|> + iI (timesExp sf) term "*" factor Ii <|> iI (divExp sf) term "DIV" factor Ii <|> + iI (modExp sf) term "MOD" factor Ii <|> iI (andExp sf) term "&" factor Ii + + + + factor <- addNT -< iI (trueExp sf) (kw "TRUE") Ii <|> iI (falseExp sf) (kw "FALSE") Ii <|> + iI (pIdExp sf) ident Ii <|> iI (pIntExp sf) int Ii <|> + iI (pParExp sf) "(" exp ")" Ii <|> iI (notExp sf) "~" factor Ii + + + ss <- addNT -< iI (pSeqStmt sf) statement (pFoldr (pSeqStmt sf, pEmptyStmt sf) (iI ";" statement Ii)) Ii + + statement <- addNT -< iI (pAssigStmt sf) ident ":" "=" exp Ii <|> + iI (pIfStmt sf) "IF" cond + (pFoldr (pCondStmtL_Cons sf, pCondStmtL_Nil sf) (iI "ELSIF" cond Ii)) + mbelse + "END" Ii <|> + iI (pWhileStmt sf) "WHILE" exp "DO" ss "END" Ii <|> + iI (pEmptyStmt sf) Ii + cond <- addNT -< iI (pCondStmt sf) exp "THEN" ss Ii + + ident <- addNT -< iI var Ii <|> iI con Ii + + mbelse <- addNT -< pMaybe (pMaybeElseStmt_Nothing sf, pMaybeElseStmt_Just sf) (iI "ELSE" ss Ii) + + exportNTs -< exportList modul $ export cs_Module modul + . export cs_Declarations decls + . export cs_Expression exp + . export cs_Factor factor + . export cs_StatementSequence ss + . export cs_Statement statement + . export cs_Ident ident + . export cs_IdentL idL + . export cs_MaybeElseStmt mbelse + . export cs_Type typ + +l1Kws = fromList ["MODULE", "BEGIN", "END", "CONST", "TYPE", "VAR", "OR", "DIV", "MOD", "IF", "ELSIF", "ELSE", "WHILE", "DO", "THEN"] + diff --git a/src/Language/Oberon0/L1/SemT1.hs b/src/Language/Oberon0/L1/SemT1.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L1/SemT1.hs @@ -0,0 +1,243 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-} + +module Language.Oberon0.L1.SemT1 where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import UU.Pretty + +import Language.Oberon0.L1.Decl + + +---- T1(L1) Pretty-Printing + +instance Show IntCmp where + show ECmp = "="; show NECmp = "#"; show LCmp = "<"; show LECmp = "<="; show GCmp = ">"; show GECmp = ">=" + +instance Show IntBOp where + show Plus = "+"; show Minus = "-"; show Times = "*"; show Div = "DIV"; show Mod = "MOD" + +instance Show IntUOp where + show Ng = "-"; show Ps = "+" + +instance Show BoolBOp where + show Or = "OR"; show And = "&" + +instance Show BoolUOp where + show Not = "~" + + + +$(attLabels ["spp","sppl","sidl"]) + +sppNT = nt_Module .*. nt_Declarations .*. nt_Type .*. nt_Decl .*. nt_Expression .*. hNil + +sppRule = use spp sppNT (>-<) empty + + +sppModule = syn spp $ do idbgn <- at ch_idbgn_Module + decls <- at ch_decls_Module + stmts <- at ch_stmts_Module + idend <- at ch_idend_Module + + let ppstmts = case (stmts # sppl) of + [] -> empty + pps -> pp_block "BEGIN " "" ";" pps + + + return $ "MODULE" >#< value idbgn >|< ";" >-< + decls # spp >-< + ppstmts >-< + "END" >#< value idend >|< "." + + +sppDeclarations = syn spp $ do cst <- at ch_cstdecl_Declarations + typ <- at ch_typdecl_Declarations + var <- at ch_vardecl_Declarations + let ppdecl decl kw = case (decl # sppl) of + [] -> empty + pps -> pp_block kw "" " " pps + return $ ppdecl cst "CONST " >-< ppdecl typ "TYPE " >-< ppdecl var "VAR " + + + +sppCstDecl = syn spp $ do id <- at ch_id_CstDecl + exp <- at ch_exp_CstDecl + return $ value id >#< "=" >#< exp # spp >|< ";" + + + +sppTypDecl = syn spp $ do id <- at ch_id_TypDecl + typ <- at ch_typ_TypDecl + return $ value id >#< "=" >#< typ # spp >|< ";" + + +sppVarDecl = syn spp $ do idl <- at ch_idl_VarDecl + typ <- at ch_typ_VarDecl + return $ case (map pp (idl # sidl)) of + [] -> empty + ppidl -> pp_block "" "" ", " ppidl >#< ":" >#< typ # spp >|< ";" + + + + +sppType = syn spp $ do id <- at ch_id_Type + return $ pp (value id) + + + +sppIntCmpExp = syn spp $ do op <- at ch_op_IntCmpExp + e1 <- at ch_e1_IntCmpExp + e2 <- at ch_e2_IntCmpExp + return $ e1 # spp >#< show op >#< e2 # spp + +sppIntBOpExp = syn spp $ do op <- at ch_op_IntBOpExp + e1 <- at ch_e1_IntBOpExp + e2 <- at ch_e2_IntBOpExp + return $ e1 # spp >#< show op >#< e2 # spp + +sppIntUOpExp = syn spp $ do op <- at ch_op_IntUOpExp + e <- at ch_e_IntUOpExp + return $ show op >#< e # spp + + +sppBoolBOpExp = syn spp $ do op <- at ch_op_BoolBOpExp + e1 <- at ch_e1_BoolBOpExp + e2 <- at ch_e2_BoolBOpExp + return $ e1 # spp >#< show op >#< e2 # spp + +sppBoolUOpExp = syn spp $ do op <- at ch_op_BoolUOpExp + e <- at ch_e_BoolUOpExp + return $ show op >#< e # spp + + +sppIdExp = syn spp $ do i <- at ch_id_IdExp + return $ pp (value i) + +sppIntExp = syn spp $ do i <- at ch_int_IntExp + return $ pp (value i) + +sppBoolExp = syn spp $ do b <- at ch_bool_BoolExp + return $ pp (if value b then "TRUE" else "FALSE") + +sppParExp = syn spp $ do e <- at ch_e_ParExp + return $ "(" >|< e # spp >|< ")" + + + +-- sppl + +spplNT = nt_DeclL .*. nt_Statement .*. nt_CondStmtL .*. nt_CondStmt .*. nt_MaybeElseStmt .*. hNil +spplRule = use sppl spplNT (++) [] + +spplDeclL_Cons = syn sppl $ do hd <- at ch_hd_DeclL_Cons + tl <- at ch_tl_DeclL_Cons + return $ (hd # spp) : (tl # sppl) + +spplDeclL_Nil = syn sppl $ do return $ [] + + +spplAssigStmt = syn sppl $ do id <- at ch_id_AssigStmt + exp <- at ch_exp_AssigStmt + return $ [ value id >#< ":=" >#< exp # spp ] + + +spplIfStmt = syn sppl $ do if_ <- at ch_if_IfStmt + elsif <- at ch_elsif_IfStmt + els <- at ch_else_IfStmt + let ppelsif = vlist $ map (" ELS" >|<) (elsif # sppl) + let ppels = case (els # sppl) of + [] -> empty + pps -> pp_block " ELSE " "" ";" pps + return $ [ if_ # sppl >-< ppelsif >-< ppels >-< "END" ] + +spplCondStmt = syn sppl $ do exp <- at ch_exp_CondStmt + ss <- at ch_ss_CondStmt + return $ [ "IF" >#< exp # spp >#< + pp_block " THEN " "" ";" (ss # sppl) ] + + +spplWhileStmt = syn sppl $ do exp <- at ch_exp_WhileStmt + ss <- at ch_ss_WhileStmt + return $ [ "WHILE" >#< exp # spp >#< + pp_block " DO " " END " ";" (ss # sppl) ] + + +spplSeqStmt = syn sppl $ do s1 <- at ch_s1_SeqStmt + s2 <- at ch_s2_SeqStmt + return $ s1 # sppl ++ s2 # sppl + + +-- sidl + +sidlNT = nt_IdentL .*. hNil +sidlRule = use sidl sidlNT (++) [] + +sidlIdentL_Cons = syn sidl $ do h <- at ch_hd_IdentL_Cons + t <- at ch_tl_IdentL_Cons + return $ (value h) : (t # sidl) + + + + +---- Aspects +aspModule = sppModule +aspDecls = sppDeclarations +aspDeclL_Cons = spplDeclL_Cons +aspDeclL_Nil = spplDeclL_Nil +aspCstDecl = sppCstDecl +aspTypDecl = sppTypDecl +aspVarDecl = sppVarDecl + +aspType = sppType + +aspAssigStmt = spplAssigStmt +aspIfStmt = spplIfStmt +aspWhileStmt = spplWhileStmt +aspSeqStmt = spplRule + +aspEmptyStmt = spplRule + +aspCondStmtL_Cons = spplRule +aspCondStmtL_Nil = spplRule +aspCondStmt = spplCondStmt + +aspMaybeElseStmt_Just = spplRule +aspMaybeElseStmt_Nothing = spplRule + + +aspIntCmpExp = sppIntCmpExp +aspIntBOpExp = sppIntBOpExp +aspIntUOpExp = sppIntUOpExp + +aspBoolBOpExp = sppBoolBOpExp +aspBoolUOpExp = sppBoolUOpExp + +aspIdExp = sppIdExp + +aspIntExp = sppIntExp +aspBoolExp = sppBoolExp +aspParExp = sppParExp + + +aspIdentL_Cons = sidlIdentL_Cons +aspIdentL_Nil = sidlRule + + + +---- Semantic Functions + + +l1t1 = mkL1 aspAssigStmt aspBoolBOpExp aspBoolExp aspBoolUOpExp aspCondStmt aspCondStmtL_Cons + aspCondStmtL_Nil aspCstDecl aspDeclL_Cons aspDeclL_Nil aspDecls aspEmptyStmt + aspIdExp aspIdentL_Cons aspIdentL_Nil aspIfStmt aspIntBOpExp aspIntCmpExp aspIntExp + aspIntUOpExp aspMaybeElseStmt_Just aspMaybeElseStmt_Nothing aspModule aspParExp + aspSeqStmt aspTypDecl aspType aspVarDecl aspWhileStmt + diff --git a/src/Language/Oberon0/L1/SemT2.hs b/src/Language/Oberon0/L1/SemT2.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L1/SemT2.hs @@ -0,0 +1,213 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, ScopedTypeVariables #-} + +module Language.Oberon0.L1.SemT2 (module Language.Oberon0.L1.SemT1, module Language.Oberon0.L1.SemT2) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..),Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import qualified Data.Map as Map + + +import Language.Oberon0.L1.Decl +import qualified Language.Oberon0.L1.SemT1 as T1 +import Language.Oberon0.L1.SemT1 (l1t1,spp,sppl,sidl) + + + +---- T2 (L1) Name binding + +$(attLabels ["senv", "ienv", "serr", "spos"]) + +data SymbolInfo a b = SI a b + deriving Show + + +data NameDef = NameDef Pos --position + String --type of definition (i.e. Cst, Typ, Var, etc.) + String --description (i.e. constant, type, variable, etc.) + deriving Show + +type NInfo a = SymbolInfo NameDef a + + +-- spos + +sposType = syn spos $ do idt <- at ch_id_Type + return $ pos idt + + +-- senv + +senvNT = nt_Declarations .*. nt_DeclL .*. nt_Decl .*. nt_IdentL .*. hNil + +senvRule (_ :: a) = use senv senvNT Map.union (Map.empty :: Map.Map String (NInfo a)) + + +senvCstDecl r = syn senv $ do id <- at ch_id_CstDecl + return $ Map.singleton (value id) + (SI (NameDef (pos id) "Cst" "constant") r) + +senvTypDecl r = syn senv $ do id <- at ch_id_TypDecl + return $ Map.singleton (value id) + (SI (NameDef (pos id) "Typ" "type") r) + + +senvIdentL_Cons r = syn senv $ do h <- at ch_hd_IdentL_Cons + t <- at ch_tl_IdentL_Cons + return $ Map.insert (value h) + (SI (NameDef (pos h) "Var" "variable") r) + (t # senv) + + +-- ienv + +ienvNT = nt_Module .*. nt_Declarations .*. nt_Type .*. nt_DeclL .*. nt_Decl .*. + nt_Statement .*. nt_CondStmtL .*. nt_CondStmt .*. nt_MaybeElseStmt .*. nt_Expression .*. nt_IdentL .*. hNil + +ienvRule _ = copy ienv ienvNT + +ienvIni r = Map.fromList [("INTEGER", SI (NameDef (Pos (-1) (-1)) "Typ" "type") r) + ,("BOOLEAN", SI (NameDef (Pos (-1) (-1)) "Typ" "type") r) + ,("TRUE", SI (NameDef (Pos (-1) (-1)) "Cst" "constant") r) + ,("FALSE", SI (NameDef (Pos (-1) (-1)) "Cst" "constant") r)] + +ienvModule r = inh ienv ienvNT $ do lhs <- at lhs + decls <- at ch_decls_Module + let env = Map.union (decls # senv) (lhs # ienv) + return $ ch_stmts_Module .=. env .*. + ch_decls_Module .=. env .*. + emptyRecord + +ienvCstDecl _ = inh ienv ienvNT $ do lhs <- at lhs + id <- at ch_id_CstDecl + return $ ch_exp_CstDecl .=. ( Map.delete (value id) . + Map.filter (\(SI (NameDef _ knd _) _) -> knd == "Cst") ) (lhs # ienv) .*. + emptyRecord + +ienvTypDecl _ = inh ienv ienvNT $ do lhs <- at lhs + id <- at ch_id_TypDecl + return $ ch_typ_TypDecl .=. Map.delete (value id) (lhs # ienv) .*. + emptyRecord + +-- serr + +serrNT = nt_Module .*. nt_Declarations .*. nt_Type .*. nt_DeclL .*. nt_Decl .*. + nt_Statement .*. nt_CondStmtL .*. nt_CondStmt .*. nt_MaybeElseStmt .*. nt_Expression .*. nt_IdentL .*. hNil + + +serrRule = use serr serrNT (++) ([] :: [String]) + +iferr cond err = if cond then err else [] + +serrModule = syn serr $ do idbgn <- at ch_idbgn_Module + decls <- at ch_decls_Module + stmts <- at ch_stmts_Module + idend <- at ch_idend_Module + let err = show (pos idend) ++ ": " ++ value idend + let nerr = iferr (value idbgn /= value idend) [ err ++ " sould be the Module name " ++ value idbgn ] + return $ nerr ++ decls # serr ++ stmts # serr + + +checkName name env expected place = + let fid = value name + err = show (pos name) ++ ": " ++ fid + in case (Map.lookup fid env) of + Just (SI (NameDef p t d) _) -> iferr (not $ elem t expected) [ err ++ " is a " ++ d ++ " identifier (defined at " ++ show p + ++ "), so can't be used in " ++ place ] + Nothing -> [ err ++ " is not defined" ] + +serrType = syn serr $ do id <- at ch_id_Type + lhs <- at lhs + return $ checkName id (lhs # ienv) ["Typ"] "a type" + + +serrAssigStmt = syn serr $ do id <- at ch_id_AssigStmt + exp <- at ch_exp_AssigStmt + lhs <- at lhs + return $ checkName id (lhs # ienv) ["Var"] "an assignment" ++ exp # serr + + +serrIdExp = syn serr $ do id <- at ch_id_IdExp + lhs <- at lhs + return $ checkName id (lhs # ienv) ["Var","Cst"] "an expression" + + +checkRep name env = + let fid = value name + err = show (pos name) ++ ": " ++ fid + in case (Map.lookup fid env) of + Just (SI (NameDef p _ _) _) -> iferr (p /= (pos name)) [ err ++ " is already defined (at " ++ show p ++ ")" ] + Nothing -> [ ] + + +serrCstDecl = syn serr $ do id <- at ch_id_CstDecl + exp <- at ch_exp_CstDecl + lhs <- at lhs + return $ checkRep id (lhs # ienv) ++ exp # serr + +serrTypDecl = syn serr $ do id <- at ch_id_TypDecl + typ <- at ch_typ_TypDecl + lhs <- at lhs + return $ checkRep id (lhs # ienv) ++ typ # serr + + +serrIdentL_Cons = syn serr $ do h <- at ch_hd_IdentL_Cons + t <- at ch_tl_IdentL_Cons + lhs <- at lhs + return $ checkRep h (lhs # ienv) ++ t # serr + + +---- Aspects +aspModule r = (ienvModule r) `ext` serrModule `ext` T1.aspModule +aspDecls r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspDecls +aspDeclL_Cons r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspDeclL_Cons +aspDeclL_Nil r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspDeclL_Nil +aspCstDecl r = (senvCstDecl r) `ext` (ienvCstDecl r) `ext` serrCstDecl `ext` T1.aspCstDecl +aspTypDecl r = (senvTypDecl r) `ext` (ienvTypDecl r) `ext` serrTypDecl `ext` T1.aspTypDecl +aspVarDecl r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspVarDecl + +aspType r = sposType `ext` (ienvRule r) `ext` serrType `ext` T1.aspType +aspAssigStmt r = (ienvRule r) `ext` serrAssigStmt `ext` T1.aspAssigStmt +aspIfStmt r = (ienvRule r) `ext` serrRule `ext` T1.aspIfStmt +aspWhileStmt r = (ienvRule r) `ext` serrRule `ext` T1.aspWhileStmt +aspSeqStmt r = (ienvRule r) `ext` serrRule `ext` T1.aspSeqStmt +aspEmptyStmt r = (ienvRule r) `ext` serrRule `ext` T1.aspEmptyStmt + + +aspCondStmtL_Cons r = (ienvRule r) `ext` serrRule `ext` T1.aspCondStmtL_Cons +aspCondStmtL_Nil r = (ienvRule r) `ext` serrRule `ext` T1.aspCondStmtL_Nil +aspCondStmt r = (ienvRule r) `ext` serrRule `ext` T1.aspCondStmt +aspMaybeElseStmt_Just r = (ienvRule r) `ext` serrRule `ext` T1.aspMaybeElseStmt_Just +aspMaybeElseStmt_Nothing r = (ienvRule r) `ext` serrRule `ext` T1.aspMaybeElseStmt_Nothing + +aspIntCmpExp r = (ienvRule r) `ext` serrRule `ext` T1.aspIntCmpExp +aspIntBOpExp r = (ienvRule r) `ext` serrRule `ext` T1.aspIntBOpExp +aspIntUOpExp r = (ienvRule r) `ext` serrRule `ext` T1.aspIntUOpExp +aspBoolBOpExp r = (ienvRule r) `ext` serrRule `ext` T1.aspBoolBOpExp +aspBoolUOpExp r = (ienvRule r) `ext` serrRule `ext` T1.aspBoolUOpExp + +aspIdExp r = (ienvRule r) `ext` serrIdExp `ext` T1.aspIdExp +aspIntExp r = (ienvRule r) `ext` serrRule `ext` T1.aspIntExp +aspBoolExp r = (ienvRule r) `ext` serrRule `ext` T1.aspBoolExp +aspParExp r = (ienvRule r) `ext` serrRule `ext` T1.aspParExp + + +aspIdentL_Cons r = (senvIdentL_Cons r) `ext` (ienvRule r) `ext` serrIdentL_Cons `ext` T1.aspIdentL_Cons +aspIdentL_Nil r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspIdentL_Nil + + + +---- Semantic Functions + + +l1t2 = mkL1 (aspAssigStmt ()) (aspBoolBOpExp ()) (aspBoolExp ()) (aspBoolUOpExp ()) (aspCondStmt ()) (aspCondStmtL_Cons ()) + (aspCondStmtL_Nil ()) (aspCstDecl ()) (aspDeclL_Cons ()) (aspDeclL_Nil ()) (aspDecls ()) (aspEmptyStmt ()) + (aspIdExp ()) (aspIdentL_Cons ()) (aspIdentL_Nil ()) (aspIfStmt ()) (aspIntBOpExp ()) (aspIntCmpExp ()) (aspIntExp ()) + (aspIntUOpExp ()) (aspMaybeElseStmt_Just ()) (aspMaybeElseStmt_Nothing ()) (aspModule ()) (aspParExp ()) + (aspSeqStmt ()) (aspTypDecl ()) (aspType ()) (aspVarDecl ()) (aspWhileStmt ()) diff --git a/src/Language/Oberon0/L1/SemT3.hs b/src/Language/Oberon0/L1/SemT3.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L1/SemT3.hs @@ -0,0 +1,342 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction, ScopedTypeVariables, DeriveDataTypeable #-} + +module Language.Oberon0.L1.SemT3 (module Language.Oberon0.L1.SemT3, module Language.Oberon0.L1.SemT2) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..),Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import qualified Data.Map as Map +import Data.List (intercalate) +import Data.Dynamic + +import Language.Oberon0.L1.Decl + +import qualified Language.Oberon0.L1.SemT2 as T2 +import Language.Oberon0.L1.SemT2 (l1t1,l1t2,spp,sidl,senv,ienv,serr,spos,SymbolInfo(..),NameDef(..),iferr) + +data TInfo = TInfo { trep :: Dynamic + , tshow :: String + , teq :: (TInfo -> Bool) } +instance Show TInfo where show = tshow + + +data UnkType = UnkType deriving Typeable +instance Show UnkType where show _ = "Unknown" + +data IntType = IntType (Maybe Int) deriving Typeable +instance Show IntType where show _ = "INTEGER" + +data BoolType = BoolType deriving Typeable +instance Show BoolType where show _ = "BOOLEAN" + +data AliasType = AliasType String TInfo deriving Typeable +instance Show AliasType where show (AliasType t _) = t + + +elemType t = let d = toDyn t + in TInfo d (show t) ((==) (dynTypeRep d) . dynTypeRep . trep . baseType) + +unkType = TInfo (toDyn UnkType) (show UnkType) (const True) +intType = elemType (IntType Nothing) +boolType = elemType BoolType + +baseType t@(TInfo d _ _) = maybe t (\(AliasType _ t') -> t') (fromDynamic d) + +aliasType s t = let at = AliasType s (baseType t) + in TInfo (toDyn at) s (checkAlias at) + +checkAlias (AliasType n1 t1) t2 = maybe (teq t1 t2) (\(AliasType n2 t2') -> n1 == n2 || teq t1 t2') (fromDynamic $ trep t2) + +intConst c = elemType (IntType c) +constVal (TInfo t _ _) = maybe Nothing (\(IntType i) -> i) (fromDynamic t) + +findType t env = maybe unkType (\(SI _ (SI ty _)) -> ty) (Map.lookup t env) +findVal t env = constVal (findType t env) + +---- T3 (L1) Type-checking + +$(attLabels ["sty", "sval", "sterr"]) + + +-- spos + +sposNT = nt_IdentL .*. nt_Expression .*. hNil + + +sposRule = use spos sposNT const (Pos 0 0) + +sposIdentL_Cons = syn spos $ do h <- at ch_hd_IdentL_Cons + return $ pos h + + +sposIntUOpExp = syn spos $ do op <- at ch_e_IntUOpExp + return $ moveLeft (op # spos) + +sposBoolUOpExp = syn spos $ do op <- at ch_e_BoolUOpExp + return $ moveLeft (op # spos) + + +sposIdExp = syn spos $ do i <- at ch_id_IdExp + return $ pos i + +sposIntExp = syn spos $ do i <- at ch_int_IntExp + return $ pos i + +sposBoolExp = syn spos $ do b <- at ch_bool_BoolExp + return $ pos b + +sposParExp = syn spos $ do e <- at ch_e_ParExp + return $ moveLeft (e # spos) + +moveLeft (Pos l c) = Pos l (c-1) +moveLeft (PosFile l c f) = PosFile l (c-1) f + + +-- sty + +styNT = nt_Expression .*. nt_Type .*. hNil + + +styIntCmpExp = syn sty $ do return $ boolType + + +styIntBOpExp = syn sty $ do return $ intType + +styIntUOpExp = syn sty $ do return $ intType + +styBoolBOpExp = syn sty $ do return $ boolType + + +styBoolUOpExp = syn sty $ do return $ boolType + + +styIdExp = syn sty $ do lhs <- at lhs + id <- at ch_id_IdExp + return $ findType (value id) (lhs # ienv) + +styIntExp = syn sty $ do return $ intType + +styBoolExp = syn sty $ do return $ boolType + +styParExp = syn sty $ do exp <- at ch_e_ParExp + return $ exp # sty + + +styType = syn sty $ do lhs <- at lhs + id <- at ch_id_Type + return $ findType (value id) (lhs # ienv) + + +-- sval + +svalNT = nt_Expression .*. hNil + +svalRule = syn sval $ do return Nothing + + +intBOp2Op :: IntBOp -> Int -> Int -> Int +intBOp2Op Plus = (+) +intBOp2Op Minus = (-) +intBOp2Op Times = (*) +intBOp2Op Div = div +intBOp2Op Mod = mod + +svalIntBOpExp = syn sval $ do op <- at ch_op_IntBOpExp + e1 <- at ch_e1_IntBOpExp + e2 <- at ch_e2_IntBOpExp + return $ do v1 <- (e1 # sval) + v2 <- (e2 # sval) + if (op == Div || op == Mod) && (v2 == 0) + then return 0 + else return $ (intBOp2Op op) v1 v2 + +intUOp2Op :: IntUOp -> Int -> Int +intUOp2Op Ng = negate +intUOp2Op Ps = id + +svalIntUOpExp = syn sval $ do op <- at ch_op_IntUOpExp + e <- at ch_e_IntUOpExp + return $ do v <- (e # sval) + return $ (intUOp2Op op) v + +svalIdExp = syn sval $ do lhs <- at lhs + i <- at ch_id_IdExp + return $ findVal (value i) (lhs # ienv) + +svalIntExp = syn sval $ do i <- at ch_int_IntExp + return $ Just (value i) + +svalParExp = syn sval $ do e <- at ch_e_ParExp + return $ e # sval + + + +-- senv + +senvNT = T2.senvNT + +senvCstDecl' r = synupdM senv $ do id <- at ch_id_CstDecl + exp <- at ch_exp_CstDecl + return $ Map.adjust (\(SI nd _) -> (SI nd (SI (intConst (exp # sval)) r))) (value id) + + +senvTypDecl' r = synupdM senv $ do id <- at ch_id_TypDecl + typ <- at ch_typ_TypDecl + let tid = value id + return $ Map.adjust (\(SI nd _) -> (SI nd (SI (aliasType tid (typ # sty)) r))) tid + + +senvVarDecl' r = synupdM senv $ do typ <- at ch_typ_VarDecl + return $ Map.map (\(SI nd _) -> (SI nd (SI (typ # sty) r))) + + +-- ienv + +ienvNT = T2.ienvNT + +ienvIni r = Map.fromList [("INTEGER", SI (NameDef (Pos (-1) (-1)) "Typ" "type") (SI intType r)) + ,("BOOLEAN", SI (NameDef (Pos (-1) (-1)) "Typ" "type") (SI boolType r)) + ,("TRUE", SI (NameDef (Pos (-1) (-1)) "Cst" "constant") (SI boolType r)) + ,("FALSE", SI (NameDef (Pos (-1) (-1)) "Cst" "constant") (SI boolType r))] + + +-- sterr + +sterrNT = nt_Declarations .*. nt_Type .*. nt_DeclL .*. nt_Decl .*. + nt_Statement .*. nt_CondStmtL .*. nt_CondStmt .*. nt_MaybeElseStmt .*. nt_Expression .*. hNil + + +sterrRule = use sterr sterrNT (++) ([] :: [String]) + + +check pos expected got = iferr (not $ (teq expected got) || (teq got unkType) || (teq expected unkType)) + [ show pos ++ ": Type error. Expected " ++ show expected ++ ", but got " ++ show got ] + +checkCst pos name env = iferr (findVal name env == Nothing) + [ show pos ++ ": The expression is not constant" ] + +checkDiv pos op v = iferr ((op == Div || op == Mod) && (v == (Just 0))) + [ show pos ++ ": Division by Zero" ] + + +sterrCstDecl = syn sterr $ do id <- at ch_id_CstDecl + exp <- at ch_exp_CstDecl + lhs <- at lhs + let err = check (exp # spos) intType (exp # sty) ++ exp # sterr + return $ if err == [] + then checkCst (exp # spos) (value id) (lhs # ienv) + else err + + +sterrAssigStmt = syn sterr $ do lhs <- at lhs + id <- at ch_id_AssigStmt + exp <- at ch_exp_AssigStmt + let expected = findType (value id) (lhs # ienv) + return $ check (exp # spos) expected (exp # sty) ++ + exp # sterr + + +sterrWhileStmt = syn sterr $ do exp <- at ch_exp_WhileStmt + ss <- at ch_ss_WhileStmt + return $ check (exp # spos) boolType (exp # sty) ++ + exp # sterr ++ ss # sterr + +sterrCondStmt = syn sterr $ do exp <- at ch_exp_CondStmt + ss <- at ch_ss_CondStmt + return $ check (exp # spos) boolType (exp # sty) ++ + exp # sterr ++ ss # sterr + + +sterrIntCmpExp = syn sterr $ do e1 <- at ch_e1_IntCmpExp + e2 <- at ch_e2_IntCmpExp + return $ check (e1 # spos) intType (e1 # sty) ++ + check (e2 # spos) intType (e2 # sty) ++ + e1 # sterr ++ e2 # sterr + +sterrIntBOpExp = syn sterr $ do op <- at ch_op_IntBOpExp + e1 <- at ch_e1_IntBOpExp + e2 <- at ch_e2_IntBOpExp + return $ checkDiv (e1 # spos) op (e2 # sval) ++ + check (e1 # spos) intType (e1 # sty) ++ + check (e2 # spos) intType (e2 # sty) ++ + e1 # sterr ++ e2 # sterr + +sterrIntUOpExp = syn sterr $ do e <- at ch_e_IntUOpExp + return $ check (e # spos) intType (e # sty) ++ + e # sterr + + +sterrBoolBOpExp = syn sterr $ do e1 <- at ch_e1_BoolBOpExp + e2 <- at ch_e2_BoolBOpExp + return $ check (e1 # spos) boolType (e1 # sty) ++ + check (e2 # spos) boolType (e2 # sty) ++ + e1 # sterr ++ e2 # sterr + +sterrBoolUOpExp = syn sterr $ do e <- at ch_e_BoolUOpExp + return $ check (e # spos) boolType (e # sty) ++ + e # sterr + + +-- serr + +serrModule' = synupdM serr $ do decls <- at ch_decls_Module + stmts <- at ch_stmts_Module + return $ \serr -> serr ++ decls # sterr ++ stmts # sterr + +---- Aspects + +pTInfo :: a -> SymbolInfo TInfo a +pTInfo _ = undefined + +aspModule r = serrModule' `ext` (T2.aspModule (pTInfo r)) +aspDecls r = sterrRule `ext` (T2.aspDecls (pTInfo r)) +aspDeclL_Cons r = sterrRule `ext` (T2.aspDeclL_Cons (pTInfo r)) +aspDeclL_Nil r = sterrRule `ext` (T2.aspDeclL_Nil (pTInfo r)) +aspCstDecl r = (senvCstDecl' r) `ext` sterrCstDecl `ext` (T2.aspCstDecl (pTInfo r)) +aspTypDecl r = (senvTypDecl' r) `ext` sterrRule `ext` (T2.aspTypDecl (pTInfo r)) +aspVarDecl r = (senvVarDecl' r) `ext` sterrRule `ext` (T2.aspVarDecl (pTInfo r)) + +aspType r = styType `ext` sterrRule `ext` (T2.aspType (pTInfo r)) + +aspAssigStmt r = sterrAssigStmt `ext` (T2.aspAssigStmt (pTInfo r)) +aspIfStmt r = sterrRule `ext` (T2.aspIfStmt (pTInfo r)) +aspWhileStmt r = sterrWhileStmt `ext` (T2.aspWhileStmt (pTInfo r)) +aspSeqStmt r = sterrRule `ext` (T2.aspSeqStmt (pTInfo r)) +aspEmptyStmt r = sterrRule `ext` (T2.aspEmptyStmt (pTInfo r)) +aspCondStmtL_Cons r = sterrRule `ext` (T2.aspCondStmtL_Cons (pTInfo r)) +aspCondStmtL_Nil r = sterrRule `ext` (T2.aspCondStmtL_Nil (pTInfo r)) +aspCondStmt r = sterrCondStmt `ext` (T2.aspCondStmt (pTInfo r)) +aspMaybeElseStmt_Just r = sterrRule `ext` (T2.aspMaybeElseStmt_Just (pTInfo r)) +aspMaybeElseStmt_Nothing r = sterrRule `ext` (T2.aspMaybeElseStmt_Nothing (pTInfo r)) + +aspIntCmpExp r = sposRule `ext` styIntCmpExp `ext` svalRule `ext` sterrIntCmpExp `ext` (T2.aspIntCmpExp (pTInfo r)) +aspIntBOpExp r = sposRule `ext` styIntBOpExp `ext` svalIntBOpExp `ext` sterrIntBOpExp `ext` (T2.aspIntBOpExp (pTInfo r)) +aspIntUOpExp r = sposIntUOpExp `ext` styIntUOpExp `ext` svalIntUOpExp `ext` sterrIntUOpExp `ext` (T2.aspIntUOpExp (pTInfo r)) + +aspBoolBOpExp r = sposRule `ext` styBoolBOpExp `ext` svalRule `ext` sterrBoolBOpExp `ext` (T2.aspBoolBOpExp (pTInfo r)) +aspBoolUOpExp r = sposBoolUOpExp `ext` styBoolUOpExp `ext` svalRule `ext` sterrBoolUOpExp `ext` (T2.aspBoolUOpExp (pTInfo r)) + +aspIdExp r = sposIdExp `ext` styIdExp `ext` svalIdExp `ext` sterrRule `ext` (T2.aspIdExp (pTInfo r)) +aspIntExp r = sposIntExp `ext` styIntExp `ext` svalIntExp `ext` sterrRule `ext` (T2.aspIntExp (pTInfo r)) +aspBoolExp r = sposBoolExp `ext` styBoolExp `ext` svalRule `ext` sterrRule `ext` (T2.aspBoolExp (pTInfo r)) +aspParExp r = sposParExp `ext` styParExp `ext` svalParExp `ext` sterrRule `ext` (T2.aspParExp (pTInfo r)) + + +aspIdentL_Cons r = sposIdentL_Cons `ext` (T2.aspIdentL_Cons (pTInfo r)) +aspIdentL_Nil r = sposRule `ext` (T2.aspIdentL_Nil (pTInfo r)) + + +---- Semantic Functions + + +l1t3 = mkL1 (aspAssigStmt ()) (aspBoolBOpExp ()) (aspBoolExp ()) (aspBoolUOpExp ()) (aspCondStmt ()) (aspCondStmtL_Cons ()) + (aspCondStmtL_Nil ()) (aspCstDecl ()) (aspDeclL_Cons ()) (aspDeclL_Nil ()) (aspDecls ()) (aspEmptyStmt ()) + (aspIdExp ()) (aspIdentL_Cons ()) (aspIdentL_Nil ()) (aspIfStmt ()) (aspIntBOpExp ()) (aspIntCmpExp ()) (aspIntExp ()) + (aspIntUOpExp ()) (aspMaybeElseStmt_Just ()) (aspMaybeElseStmt_Nothing ()) (aspModule ()) (aspParExp ()) + (aspSeqStmt ()) (aspTypDecl ()) (aspType ()) (aspVarDecl ()) (aspWhileStmt ()) diff --git a/src/Language/Oberon0/L1/SemT5.hs b/src/Language/Oberon0/L1/SemT5.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L1/SemT5.hs @@ -0,0 +1,349 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-} + +module Language.Oberon0.L1.SemT5 (module Language.Oberon0.L1.SemT5, module Language.Oberon0.L1.SemT3) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..),Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import qualified Data.Map as Map +import Language.C + +import Language.Oberon0.L1.Decl + +import qualified Language.Oberon0.L1.SemT3 as T3 +import Language.Oberon0.L1.SemT3 (l1t1,l1t2,l1t3,spp,sidl,senv,ienv,serr,spos,sty,sterr,check + ,SymbolInfo(..),NameDef(..),TInfo(..),baseType,intType,boolType,unkType,findType) + +---- T5(L1) Code Generation + + +compStmt s1 s2 = let c1 = case s1 of + CCompound _ cbl _ -> cbl + cb -> [ CBlockStmt cb ] + c2 = case s2 of + CCompound _ cbl _ -> cbl + cb -> [ CBlockStmt cb ] + + in CCompound [] (c1 ++ c2) undefNode + + +mapIdent sid env = internalIdent $ maybe sid (\(SI _ (SI _ (SI i _))) -> i) (Map.lookup sid env) + + +$(attLabels ["scgen","scdecl","scty","scexp","scstmt","ipre"]) + + +-- ipre + +ipreNT = nt_Declarations .*. nt_DeclL .*. nt_Decl .*. + nt_Statement .*. nt_CondStmtL .*. nt_CondStmt .*. nt_MaybeElseStmt .*. nt_Expression .*. nt_Type .*. hNil + +ipreRule = copy ipre ipreNT + +-- top-level definitions prefixed by: __ +-- no c reserved word starts with _ +ipreModule = inh ipre ipreNT $ do id <- at ch_idbgn_Module + return $ ch_stmts_Module .=. ("_" ++ value id ++ "_") .*. + ch_decls_Module .=. ("_" ++ value id ++ "_") .*. + emptyRecord + +-- senv + +senvNT = T3.senvNT + +updMap ni r (SI nd (SI ti _)) = (SI nd (SI ti (SI ni r))) + +senvCstDecl' r = synupdM senv $ do lhs <- at lhs + id <- at ch_id_CstDecl + let cid = value id + return $ Map.adjust (updMap (lhs # ipre ++ cid) r) cid + + +senvTypDecl' r = synupdM senv $ do lhs <- at lhs + id <- at ch_id_TypDecl + let tid = value id + return $ Map.adjust (updMap (lhs # ipre ++ tid) r) tid + + +senvVarDecl' r = synupdM senv $ do lhs <- at lhs + return $ Map.mapWithKey (\k -> updMap (lhs # ipre ++ k) r) + +-- ienv + +ienvNT = T3.ienvNT + +ienvIni r = Map.fromList [("INTEGER", SI (NameDef (Pos (-1) (-1)) "Typ" "type") (SI intType (SI "int" r))) + ,("BOOLEAN", SI (NameDef (Pos (-1) (-1)) "Typ" "type") (SI boolType (SI "int" r))) + ,("TRUE", SI (NameDef (Pos (-1) (-1)) "Cst" "constant") (SI boolType (SI "int" r))) + ,("FALSE", SI (NameDef (Pos (-1) (-1)) "Cst" "constant") (SI boolType (SI "int" r)))] + + +ienvModule' r = inhmodM ienv ienvNT $ do lhs <- at lhs + decls <- at ch_decls_Module + let env = Map.union (decls # senv) (lhs # ienv) + return $ ch_stmts_Module .=. env .*. + ch_decls_Module .=. env .*. + emptyRecord + +-- scgen + +scgenNT = nt_Module .*. hNil + +scgenModule = syn scgen $ do idbgn <- at ch_idbgn_Module + decls <- at ch_decls_Module + stmts <- at ch_stmts_Module + idend <- at ch_idend_Module + let mainfun = [ CFDefExt (CFunDef [CTypeSpec (CIntType undefNode)] + (CDeclr (Just $ (internalIdent "main")) + [CFunDeclr (Right ([],False)) [] undefNode] + Nothing [] undefNode) + [] + (compStmt (stmts # scstmt) + (CReturn (Just (CConst (CIntConst (cInteger 0) undefNode))) undefNode )) + undefNode) + ] + return $ CTranslUnit (decls # scdecl ++ mainfun) undefNode + +-- scdecl + +scdeclNT = nt_Declarations .*. nt_DeclL .*. nt_Decl .*. hNil + +scdeclRule = use scdecl scdeclNT (++) ([] :: [CExternalDeclaration NodeInfo]) + +scdeclCstDecl = syn scdecl $ do lhs <- at lhs + id <- at ch_id_CstDecl + exp <- at ch_exp_CstDecl + return [ CDeclExt $ + CDecl [CTypeSpec (CEnumType (CEnum Nothing (Just [( mapIdent (value id) (lhs # ienv), Just (exp # scexp))]) + [] + undefNode) + undefNode)] + [ ] + undefNode + ] + + +scdeclTypDecl = syn scdecl $ do lhs <- at lhs + id <- at ch_id_TypDecl + typ <- at ch_typ_TypDecl + let (tys,tyd) = typ # scty + return [ CDeclExt $ + CDecl [CStorageSpec (CTypedef undefNode), tys] + [ ( Just (CDeclr (Just $ mapIdent (value id) (lhs # ienv)) tyd Nothing [] undefNode), Nothing, Nothing)] + undefNode + ] + + +scdeclVarDecl = syn scdecl $ do lhs <- at lhs + idl <- at ch_idl_VarDecl + typ <- at ch_typ_VarDecl + let (tys,tyd) = typ # scty + let vars = map (\name -> (Just (CDeclr (Just $ mapIdent name (lhs # ienv)) tyd Nothing [] undefNode),Nothing,Nothing)) + (idl # sidl) + return [ CDeclExt $ CDecl [ tys ] vars undefNode ] + +-- scty + +type CType = (CTypeSpec, [CDerivedDeclr]) + +sctyType = syn scty $ do lhs <- at lhs + id <- at ch_id_Type + return (CTypeSpec (CTypeDef (mapIdent (value id) (lhs # ienv)) undefNode), []) + + +-- scexp + +scexpNT = nt_Expression .*. hNil + +intCmp2C :: IntCmp -> CBinaryOp +intCmp2C ECmp = CEqOp +intCmp2C NECmp = CNeqOp +intCmp2C LCmp = CLeOp +intCmp2C LECmp = CLeqOp +intCmp2C GCmp = CGrOp +intCmp2C GECmp = CGeqOp + +scexpIntCmpExp = syn scexp $ do op <- at ch_op_IntCmpExp + e1 <- at ch_e1_IntCmpExp + e2 <- at ch_e2_IntCmpExp + return $ CBinary (intCmp2C op) (e1 # scexp) (e2 # scexp) undefNode + + + +intBOp2C :: IntBOp -> CBinaryOp +intBOp2C Plus = CAddOp +intBOp2C Minus = CSubOp +intBOp2C Times = CMulOp +intBOp2C Div = CDivOp +intBOp2C Mod = CRmdOp + + +scexpIntBOpExp = syn scexp $ do op <- at ch_op_IntBOpExp + e1 <- at ch_e1_IntBOpExp + e2 <- at ch_e2_IntBOpExp + return $ CBinary (intBOp2C op) (e1 # scexp) (e2 # scexp) undefNode + +intUOp2C :: IntUOp -> CUnaryOp +intUOp2C Ng = CMinOp +intUOp2C Ps = CPlusOp + + +scexpIntUOpExp = syn scexp $ do op <- at ch_op_IntUOpExp + e <- at ch_e_IntUOpExp + return $ CUnary (intUOp2C op) (e # scexp) undefNode + + +boolBOp2C :: BoolBOp -> CBinaryOp +boolBOp2C Or = CLorOp +boolBOp2C And = CLndOp + + +scexpBoolBOpExp = syn scexp $ do op <- at ch_op_BoolBOpExp + e1 <- at ch_e1_BoolBOpExp + e2 <- at ch_e2_BoolBOpExp + return $ CBinary (boolBOp2C op) (e1 # scexp) (e2 # scexp) undefNode + + +boolUOp2C :: BoolUOp -> CUnaryOp +boolUOp2C Not = CNegOp + + +scexpBoolUOpExp = syn scexp $ do op <- at ch_op_BoolUOpExp + e <- at ch_e_BoolUOpExp + return $ CUnary (boolUOp2C op) (e # scexp) undefNode + + +scexpIdExp = syn scexp $ do lhs <- at lhs + i <- at ch_id_IdExp + return $ CVar (mapIdent (value i) (lhs # ienv)) undefNode + +scexpIntExp = syn scexp $ do i <- at ch_int_IntExp + return $ CConst (CIntConst (cInteger $ (toInteger . value) i) undefNode) + +scexpBoolExp = syn scexp $ do b <- at ch_bool_BoolExp + return $ CConst (CIntConst (cInteger $ (if value b then 1 else 0)) undefNode) + +scexpParExp = syn scexp $ do e <- at ch_e_ParExp + return $ e # scexp + + + + +-- scstmt + +scstmtNT = nt_Statement .*. nt_CondStmtL .*. nt_CondStmt .*. nt_MaybeElseStmt .*. hNil + +scstmtAssigStmt = syn scstmt $ do lhs <- at lhs + id <- at ch_id_AssigStmt + exp <- at ch_exp_AssigStmt + let cid = CVar (mapIdent (value id) (lhs # ienv)) undefNode + return $ CExpr (Just $ CAssign CAssignOp cid (exp # scexp) undefNode) undefNode + +combCIf (Just (CIf c s me n)) els = Just $ CIf c s (combCIf me els) n +combCIf Nothing els = els + +scstmtIfStmt = syn scstmt $ do if_ <- at ch_if_IfStmt + elsif <- at ch_elsif_IfStmt + els <- at ch_else_IfStmt + return $ case (if_ # scstmt) of + CIf c s _ n -> CIf c s (combCIf (elsif # scstmt) (els # scstmt)) n + +scstmtCondStmt = syn scstmt $ do exp <- at ch_exp_CondStmt + ss <- at ch_ss_CondStmt + return $ CIf (exp # scexp) (ss # scstmt) Nothing undefNode + + +-- have type (Maybe CStatement) +scstmtCondStmtL_Cons = syn scstmt $ do h <- at ch_hd_CondStmtL_Cons + t <- at ch_tl_CondStmtL_Cons + return $ case h # scstmt of + CIf c s _ n -> Just $ CIf c s (t # scstmt) n + +scstmtCondStmtL_Nil = syn scstmt $ do return $ Nothing + + +scstmtMaybeElseStmt_Just = syn scstmt $ do j <- at ch_just_MaybeElseStmt_Just + return $ Just (j # scstmt) + +scstmtMaybeElseStmt_Nothing = syn scstmt $ do return $ Nothing +-- + + +scstmtWhileStmt = syn scstmt $ do exp <- at ch_exp_WhileStmt + ss <- at ch_ss_WhileStmt + return $ CWhile (exp # scexp) (ss # scstmt) False undefNode + + + +scstmtSeqStmt = syn scstmt $ do s1 <- at ch_s1_SeqStmt + s2 <- at ch_s2_SeqStmt + return $ compStmt (s1 # scstmt) (s2 # scstmt) + +scstmtEmptyStmt = syn scstmt $ do return $ CExpr Nothing undefNode + + + +---- Aspects + +pMap :: a -> SymbolInfo String a +pMap _ = undefined + + +aspModule r = (ienvModule' r) `ext` ipreModule `ext` scgenModule `ext` (T3.aspModule (pMap r)) +aspDecls r = ipreRule `ext` scdeclRule `ext` (T3.aspDecls (pMap r)) +aspDeclL_Cons r = ipreRule `ext` scdeclRule `ext` (T3.aspDeclL_Cons (pMap r)) +aspDeclL_Nil r = ipreRule `ext` scdeclRule `ext` (T3.aspDeclL_Nil (pMap r)) +aspCstDecl r = (senvCstDecl' r) `ext` ipreRule `ext` scdeclCstDecl `ext` (T3.aspCstDecl (pMap r)) +aspTypDecl r = (senvTypDecl' r) `ext` ipreRule `ext` scdeclTypDecl `ext` (T3.aspTypDecl (pMap r)) +aspVarDecl r = (senvVarDecl' r) `ext` ipreRule `ext` scdeclVarDecl `ext` (T3.aspVarDecl (pMap r)) + +aspType r = ipreRule `ext` sctyType `ext` (T3.aspType (pMap r)) + +aspAssigStmt r = ipreRule `ext` scstmtAssigStmt `ext` (T3.aspAssigStmt (pMap r)) +aspIfStmt r = ipreRule `ext` scstmtIfStmt `ext` (T3.aspIfStmt (pMap r)) +aspWhileStmt r = ipreRule `ext` scstmtWhileStmt `ext` (T3.aspWhileStmt (pMap r)) +aspSeqStmt r = ipreRule `ext` scstmtSeqStmt `ext` (T3.aspSeqStmt (pMap r)) + +aspEmptyStmt r = ipreRule `ext` scstmtEmptyStmt `ext` (T3.aspEmptyStmt (pMap r)) + +aspCondStmtL_Cons r = ipreRule `ext` scstmtCondStmtL_Cons `ext` (T3.aspCondStmtL_Cons (pMap r)) +aspCondStmtL_Nil r = ipreRule `ext` scstmtCondStmtL_Nil `ext` (T3.aspCondStmtL_Nil (pMap r)) +aspCondStmt r = ipreRule `ext` scstmtCondStmt `ext` (T3.aspCondStmt (pMap r)) + +aspMaybeElseStmt_Just r = ipreRule `ext` scstmtMaybeElseStmt_Just `ext` (T3.aspMaybeElseStmt_Just (pMap r)) +aspMaybeElseStmt_Nothing r = ipreRule `ext` scstmtMaybeElseStmt_Nothing `ext` (T3.aspMaybeElseStmt_Nothing (pMap r)) + + +aspIntCmpExp r = ipreRule `ext` scexpIntCmpExp `ext` (T3.aspIntCmpExp (pMap r)) +aspIntBOpExp r = ipreRule `ext` scexpIntBOpExp `ext` (T3.aspIntBOpExp (pMap r)) +aspIntUOpExp r = ipreRule `ext` scexpIntUOpExp `ext` (T3.aspIntUOpExp (pMap r)) + +aspBoolBOpExp r = ipreRule `ext` scexpBoolBOpExp `ext` (T3.aspBoolBOpExp (pMap r)) +aspBoolUOpExp r = ipreRule `ext` scexpBoolUOpExp `ext` (T3.aspBoolUOpExp (pMap r)) + +aspIdExp r = ipreRule `ext` scexpIdExp `ext` (T3.aspIdExp (pMap r)) + +aspIntExp r = ipreRule `ext` scexpIntExp `ext` (T3.aspIntExp (pMap r)) +aspBoolExp r = ipreRule `ext` scexpBoolExp `ext` (T3.aspBoolExp (pMap r)) +aspParExp r = ipreRule `ext` scexpParExp `ext` (T3.aspParExp (pMap r)) + + +aspIdentL_Cons r = (T3.aspIdentL_Cons (pMap r)) +aspIdentL_Nil r = (T3.aspIdentL_Nil (pMap r)) + + + +---- Semantic Functions + + +l1t5 = mkL1 (aspAssigStmt ()) (aspBoolBOpExp ()) (aspBoolExp ()) (aspBoolUOpExp ()) (aspCondStmt ()) (aspCondStmtL_Cons ()) + (aspCondStmtL_Nil ()) (aspCstDecl ()) (aspDeclL_Cons ()) (aspDeclL_Nil ()) (aspDecls ()) (aspEmptyStmt ()) + (aspIdExp ()) (aspIdentL_Cons ()) (aspIdentL_Nil ()) (aspIfStmt ()) (aspIntBOpExp ()) (aspIntCmpExp ()) (aspIntExp ()) + (aspIntUOpExp ()) (aspMaybeElseStmt_Just ()) (aspMaybeElseStmt_Nothing ()) (aspModule ()) (aspParExp ()) + (aspSeqStmt ()) (aspTypDecl ()) (aspType ()) (aspVarDecl ()) (aspWhileStmt ()) diff --git a/src/Language/Oberon0/L1/T1.hs b/src/Language/Oberon0/L1/T1.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L1/T1.hs @@ -0,0 +1,14 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.MainT1 +import Language.Oberon0.L1.Gram +import Language.Oberon0.L1.SemT1 + + +import Language.Grammars.Murder +import Language.Grammars.AspectAG + + +c_l1t1 = closeGram (l1 l1t1) + +main = mainT1 (# spp) emptyRecord "l1t1" l1Kws c_l1t1 diff --git a/src/Language/Oberon0/L1/T2.hs b/src/Language/Oberon0/L1/T2.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L1/T2.hs @@ -0,0 +1,17 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.L1.Gram +import Language.Oberon0.L1.SemT2 +import Language.Oberon0.MainT2 + +import Language.Grammars.Murder +import Language.Grammars.Murder.UUParsing + +import Language.Grammars.AspectAG + + +c_l1t2 = closeGram (l1 l1t2) + + +main = mainT2 (# spp) (# serr) (ienv .=. ienvIni () .*. emptyRecord) "l1t2" l1Kws c_l1t2 + diff --git a/src/Language/Oberon0/L1/T3.hs b/src/Language/Oberon0/L1/T3.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L1/T3.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.L1.Gram +import Language.Oberon0.L1.SemT3 +import Language.Oberon0.MainT2 + +import Language.Grammars.Murder +import Language.Grammars.AspectAG + + +c_l1t3 = closeGram (l1 l1t3) + + +main = mainT2 (# spp) (# serr) (ienv .=. ienvIni () .*. emptyRecord) "l1t3" l1Kws c_l1t3 + diff --git a/src/Language/Oberon0/L1/T5.hs b/src/Language/Oberon0/L1/T5.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L1/T5.hs @@ -0,0 +1,18 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.L1.Gram +import Language.Oberon0.L1.SemT5 +import Language.Oberon0.MainT5 + +import Language.Grammars.Murder +import Language.Grammars.Murder.UUParsing + +import Language.Grammars.AspectAG + + +c_l1t5 = closeGram (l1 l1t5) + + +main = mainT5 (# spp) (# serr) (# scgen) (ienv .=. ienvIni () .*. emptyRecord) "l1t5" l1Kws c_l1t5 + + diff --git a/src/Language/Oberon0/L2/Decl.hs b/src/Language/Oberon0/L2/Decl.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L2/Decl.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-} + +module Language.Oberon0.L2.Decl (module Language.Oberon0.L1.Decl, module Language.Oberon0.L2.Decl) where + +import Language.Oberon0.L1.Decl hiding (mkL1) +import qualified Language.Oberon0.L1.Decl as L1 + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive + +import Language.Grammars.Grammar(mkDTerm) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 + +---- L2 Grammar + + +data EXT_Statement + = ForStmt { id_ForStmt :: String, start_ForStmt :: Expression, dir_ForStmt :: ForDir + , stop_ForStmt :: Expression, step_ForStmt :: Expression, ss_ForStmt :: Statement } + | CaseStmt { exp_CaseStmt :: Expression, case_CaseStmt :: Case, cases_CaseStmt :: CaseL, else_CaseStmt :: MaybeElseStmt } + + +data ForDir = To | Downto deriving Show + + +type CaseL = [Case] + +data Case = Case { label_Case :: LabelL, ss_Case :: Statement } + +type LabelL = [Label] + +data Label = ExpreLbl { exp_ExpreLbl :: Expression } + | RangeLbl { e1_RangeLbl :: Expression, e2_RangeLbl :: Expression } + + +$(extendAG ''EXT_Statement [''Statement, ''MaybeElseStmt, ''Expression]) + + +data EXT_Expression = Cst1Exp + +$(extendAG ''EXT_Expression [ ]) + + +$(deriveLang "L2" [''EXT_Statement, ''ForDir, ''CaseL, ''Case, ''LabelL, ''Label, ''EXT_Expression]) + +---- FOR Macro + +$(attLabels ["self"]) + + +macroForStmt aspSeqStmt aspAssigStmt aspWhileStmt aspIntCmpExp aspIdExp aspIntBOpExp + = withChildAtt ch_dir_ForStmt self $ \dir -> + let (op_stop,op_step) = case dir of + To -> (LECmp,Plus) + Downto -> (GECmp,Minus) + + in agMacro ( aspSeqStmt + , ch_s1_SeqStmt ==> ( aspAssigStmt + , ch_id_AssigStmt --> ch_id_ForStmt + <.> ch_exp_AssigStmt --> ch_start_ForStmt + ) + <.> ch_s2_SeqStmt ==> ( aspWhileStmt + , ch_exp_WhileStmt ==> ( aspIntCmpExp + , ch_op_IntCmpExp ~~> op_stop + <.> ch_e1_IntCmpExp ==> (aspIdExp, ch_id_IdExp --> ch_id_ForStmt) + <.> ch_e2_IntCmpExp --> ch_stop_ForStmt + ) + <.> ch_ss_WhileStmt ==> ( aspSeqStmt + , ch_s1_SeqStmt --> ch_ss_ForStmt + <.> ch_s2_SeqStmt ==> ( aspAssigStmt + , ch_id_AssigStmt --> ch_id_ForStmt + <.> ch_exp_AssigStmt ==> ( aspIntBOpExp + , ch_op_IntBOpExp ~~> op_step + <.> ch_e1_IntBOpExp ==> ( aspIdExp + , ch_id_IdExp --> ch_id_ForStmt + ) + <.> ch_e2_IntBOpExp --> ch_step_ForStmt + ) + ) + ) + ) + <.> ignore ch_dir_ForStmt + ) + + + +macroCst1Exp aspIntExp = agMacro ( aspIntExp, ch_int_IntExp ~~> (mkDTerm (1::Int))) + + + +-- CASE Macro + + +caseVar = (mkDTerm "0case") -- we use a non-valid Oberon-0 name to avoid collision + +macroCaseStmt aspSeqStmt aspAssigStmt aspIfStmt + = agMacro ( aspSeqStmt + , ch_s1_SeqStmt ==> ( aspAssigStmt + , ch_id_AssigStmt ~~> caseVar + <.> ch_exp_AssigStmt --> ch_exp_CaseStmt + ) + <.> ch_s2_SeqStmt ==> ( aspIfStmt + , ch_if_IfStmt --> ch_case_CaseStmt + <.> ch_elsif_IfStmt --> ch_cases_CaseStmt + <.> ch_else_IfStmt --> ch_else_CaseStmt + ) + ) + +macroCaseL_Cons aspCondStmtL_Cons + = agMacro ( aspCondStmtL_Cons + , ch_hd_CondStmtL_Cons --> ch_hd_CaseL_Cons + <.> ch_tl_CondStmtL_Cons --> ch_tl_CaseL_Cons + ) + +macroCaseL_Nil aspCondStmtL_Nil + = agMacro ( aspCondStmtL_Nil + , noChild + ) + +macroCase aspCondStmt + = agMacro ( aspCondStmt + , ch_exp_CondStmt --> ch_label_Case + <.> ch_ss_CondStmt --> ch_ss_Case + ) + +macroLabelL_Cons aspBoolBOpExp + = agMacro ( aspBoolBOpExp + , ch_op_BoolBOpExp ~~> Or + <.> ch_e1_BoolBOpExp --> ch_hd_LabelL_Cons + <.> ch_e2_BoolBOpExp --> ch_tl_LabelL_Cons + ) + +macroLabelL_Nil aspBoolExp + = agMacro ( aspBoolExp + , ch_bool_BoolExp ~~> (mkDTerm (False)) + ) + + +macroExpreLbl aspIntCmpExp aspIdExp + = agMacro ( aspIntCmpExp + , ch_op_IntCmpExp ~~> ECmp + <.> ch_e1_IntCmpExp ==> (aspIdExp, ch_id_IdExp ~~> caseVar) + <.> ch_e2_IntCmpExp --> ch_exp_ExpreLbl + ) + +macroRangeLbl aspIntCmpExp aspBoolBOpExp aspIdExp + = agMacro ( aspBoolBOpExp + , ch_op_BoolBOpExp ~~> And + <.> ch_e1_BoolBOpExp ==> ( aspIntCmpExp + , ch_op_IntCmpExp ~~> GECmp + <.> ch_e1_IntCmpExp ==> (aspIdExp, ch_id_IdExp ~~> caseVar) + <.> ch_e2_IntCmpExp --> ch_e1_RangeLbl + ) + <.> ch_e2_BoolBOpExp ==> ( aspIntCmpExp + , ch_op_IntCmpExp ~~> LECmp + <.> ch_e1_IntCmpExp ==> (aspIdExp, ch_id_IdExp ~~> caseVar) + <.> ch_e2_IntCmpExp --> ch_e2_RangeLbl + ) + ) + + + +macroDeclarations aspDeclarations aspDeclL_Cons aspVarDecl aspIdentL_Cons aspIdentL_Nil aspType + = agMacro ( aspDeclarations + , ch_cstdecl_Declarations --> ch_cstdecl_Declarations + <.> ch_typdecl_Declarations --> ch_typdecl_Declarations + <.> ch_vardecl_Declarations ==> ( aspDeclL_Cons + , ch_hd_DeclL_Cons ==> ( aspVarDecl + , ch_idl_VarDecl ==> ( aspIdentL_Cons + , ch_hd_IdentL_Cons ~~> caseVar + <.> ch_tl_IdentL_Cons ==> (aspIdentL_Nil, noChild) + ) + <.> ch_typ_VarDecl ==> ( aspType + , ch_id_Type ~~> (mkDTerm "INTEGER") + ) + ) + <.> ch_tl_DeclL_Cons --> ch_vardecl_Declarations + ) + ) + + + +mkL2' _aspCase _aspCaseL_Cons _aspCaseL_Nil + _aspCaseStmt _aspCst1Exp _aspDownto _aspExpreLbl + _aspForStmt _aspLabelL_Cons _aspLabelL_Nil _aspRangeLbl _aspTo + + _aspAssigStmt _aspBoolBOpExp _aspBoolExp _aspCondStmt _aspCondStmtL_Cons _aspCondStmtL_Nil + _aspIfStmt _aspIdExp _aspIntBOpExp _aspIntCmpExp _aspIntExp _aspSeqStmt _aspWhileStmt + + = mkL2 (_aspCase (macroCase _aspCondStmt) ) + (_aspCaseL_Cons (macroCaseL_Cons _aspCondStmtL_Cons)) + (_aspCaseL_Nil (macroCaseL_Nil _aspCondStmtL_Nil)) + (_aspCaseStmt (macroCaseStmt _aspSeqStmt _aspAssigStmt _aspIfStmt)) + (_aspCst1Exp (macroCst1Exp _aspIntExp)) + _aspDownto + (_aspExpreLbl (macroExpreLbl _aspIntCmpExp _aspIdExp)) + (_aspForStmt (macroForStmt _aspSeqStmt _aspAssigStmt _aspWhileStmt _aspIntCmpExp _aspIdExp _aspIntBOpExp)) + (_aspLabelL_Cons (macroLabelL_Cons _aspBoolBOpExp)) + (_aspLabelL_Nil (macroLabelL_Nil _aspBoolExp)) + (_aspRangeLbl (macroRangeLbl _aspIntCmpExp _aspBoolBOpExp _aspIdExp)) + _aspTo + +mkL1 aspAssigStmt aspBoolBOpExp aspBoolExp aspBoolUOpExp aspCondStmt aspCondStmtL_Cons + aspCondStmtL_Nil aspCstDecl aspDeclL_Cons aspDeclL_Nil aspDecls aspEmptyStmt + aspIdExp aspIdentL_Cons aspIdentL_Nil aspIfStmt aspIntBOpExp aspIntCmpExp aspIntExp + aspIntUOpExp aspMaybeElseStmt_Just aspMaybeElseStmt_Nothing aspModule aspParExp + aspSeqStmt aspTypDecl aspType aspVarDecl aspWhileStmt + = L1.mkL1 aspAssigStmt aspBoolBOpExp aspBoolExp aspBoolUOpExp aspCondStmt aspCondStmtL_Cons + aspCondStmtL_Nil aspCstDecl aspDeclL_Cons aspDeclL_Nil + (macroDeclarations aspDecls aspDeclL_Cons aspVarDecl aspIdentL_Cons aspIdentL_Nil aspType) + aspEmptyStmt + aspIdExp aspIdentL_Cons aspIdentL_Nil aspIfStmt aspIntBOpExp aspIntCmpExp aspIntExp + aspIntUOpExp aspMaybeElseStmt_Just aspMaybeElseStmt_Nothing aspModule aspParExp + aspSeqStmt aspTypDecl aspType aspVarDecl aspWhileStmt diff --git a/src/Language/Oberon0/L2/Gram.hs b/src/Language/Oberon0/L2/Gram.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L2/Gram.hs @@ -0,0 +1,45 @@ +{-# OPTIONS -fcontext-stack=100 #-} + +{-# LANGUAGE Arrows, DoRec #-} + +module Language.Oberon0.L2.Gram (module Language.Oberon0.L2.Gram, module Language.Oberon0.L1.Gram) where + +import Language.Oberon0.L1.Gram +import Language.Oberon0.L2.Decl + +import Control.Arrow +import Control.Applicative +import Data.Set (union,fromList) + +import Language.Grammars.Murder +import Language.Grammars.Grammar +import Language.Grammars.AspectAG + + +l2 sf = proc imported -> do + let ss = getNT cs_StatementSequence imported + let statement = getNT cs_Statement imported + let exp = getNT cs_Expression imported + let ident = getNT cs_Ident imported + let mbelse = getNT cs_MaybeElseStmt imported + + + rec addProds -< (statement, iI (pForStmt sf) "FOR" ident ":" "=" exp dir exp mbexp "DO" ss "END" Ii <|> + iI (pCaseStmt sf) "CASE" exp "OF" c cs mbelse "END" Ii) + + dir <- addNT -< iI (pTo sf) "TO" Ii <|> iI (pDownto sf) "DOWNTO" Ii + mbexp <- addNT -< pMaybe (pCst1Exp sf, id) (iI "BY" exp Ii) + + + cs <- addNT -< pFoldr (pCaseL_Cons sf, pCaseL_Nil sf) (iI "|" c Ii) + c <- addNT -< iI (pCase sf) labels ":" ss Ii + + labels <- addNT -< iI (pLabelL_Cons sf) label (pFoldr (pLabelL_Cons sf, pLabelL_Nil sf) (iI "," label Ii)) Ii + label <- addNT -< iI (pExpreLbl sf) exp Ii <|> iI (pRangeLbl sf) exp ".." exp Ii + + + + exportNTs -< imported + +l2Kws = union l1Kws $ fromList ["FOR", "DO", "CASE", "OF", "TO", "DOWNTO", "BY"] + diff --git a/src/Language/Oberon0/L2/SemT1.hs b/src/Language/Oberon0/L2/SemT1.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L2/SemT1.hs @@ -0,0 +1,157 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-} + +module Language.Oberon0.L2.SemT1 (module Language.Oberon0.L2.SemT1, module Language.Oberon0.L1.SemT1) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..), Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import UU.Pretty + +import Language.Oberon0.L2.Decl + +import qualified Language.Oberon0.L1.SemT1 as L1 +import Language.Oberon0.L1.SemT1 (spp,sppl,sidl) + + + + +selfTo = syn self $ do return $ To +selfDownto = syn self $ do return $ Downto + + +---- T1(L2) Pretty-Printing + + +sppNT = nt_ForDir .*. nt_Label .*. nt_LabelL .*. L1.sppNT + + + +sppTo = syn spp $ do return $ pp "TO" +sppDownto = syn spp $ do return $ pp "DOWNTO" + + +sppLabelL_Cons = synmodM spp $ do hd <- at ch_hd_LabelL_Cons + tl <- at ch_tl_LabelL_Cons + let pptl = tl # spp + return $ hd # spp >|< (if show pptl == ":" then empty else pp ",") >#< pptl + +sppLabelL_Nil = synmodM spp $ do return $ pp ":" + +sppExpreLbl = synmodM spp $ do exp <- at ch_exp_ExpreLbl + return $ exp # spp + +sppRangeLbl = synmodM spp $ do e1 <- at ch_e1_RangeLbl + e2 <- at ch_e2_RangeLbl + return $ e1 # spp >#< ".." >#< e2 # spp + + + +-- sppl + +spplNT = nt_CaseL .*. nt_Case .*. L1.spplNT + +spplForStmt = synmodM sppl $ do id <- at ch_id_ForStmt + start <- at ch_start_ForStmt + dir <- at ch_dir_ForStmt + stop <- at ch_stop_ForStmt + step <- at ch_step_ForStmt + ss <- at ch_ss_ForStmt + return $ [ "FOR" >#< value id >#< ":=" >#< + start # spp >#< dir # spp >#< stop # spp >#< + "BY" >#< step # spp >#< pp_block " DO " " END " ";" (ss # sppl) ] + + +spplCaseStmt = synmodM sppl $ do exp <- at ch_exp_CaseStmt + c <- at ch_case_CaseStmt + cs <- at ch_cases_CaseStmt + e <- at ch_else_CaseStmt + let ppels = case (e # sppl) of + [] -> empty + pps -> pp_block " ELSE " "" ";" pps + + return $ [ "CASE" >#< exp # spp >#< "OF" >-< + pp_block "" "" "|" (c # sppl ++ cs # sppl) >-< + ppels >-< "END" ] + +spplCase = synmodM sppl $ do ls <- at ch_label_Case + ss <- at ch_ss_Case + return $ [ ls # spp >#< pp_block "" "" ";" (ss # sppl) ] + + + +sppVarDecl' = synmodM spp $ do idl <- at ch_idl_VarDecl + typ <- at ch_typ_VarDecl + let ppidl = (map pp . filter (/= value caseVar)) (idl # sidl) + return $ case ppidl of + [] -> empty + _ -> pp_block "" "" ", " ppidl >#< ":" >#< typ # spp >|< ";" + + +{- +sidlIdentL_Cons' + = synmodM sidl $ do h <- at ch_hd_IdentL_Cons + t <- at ch_tl_IdentL_Cons + return $ if h == caseVar + then (t # sidl) + else (value h) : (t # sidl) +-} + +---- Aspects + +aspForStmt _macroForStmt = spplForStmt `ext` _macroForStmt +aspTo = sppTo `ext` selfTo +aspDownto = sppDownto `ext` selfDownto + +aspCaseStmt _macroCaseStmt = spplCaseStmt `ext` _macroCaseStmt +aspCaseL_Cons _macroCaseL_Cons = _macroCaseL_Cons +aspCaseL_Nil _macroCaseL_Nil = _macroCaseL_Nil +aspCase _macroCase = spplCase `ext` _macroCase + +aspLabelL_Cons _macroLabelL_Cons = sppLabelL_Cons `ext` _macroLabelL_Cons +aspLabelL_Nil _macroLabelL_Nil = sppLabelL_Nil `ext` _macroLabelL_Nil + +aspExpreLbl _macroExpreLbl = sppExpreLbl `ext` _macroExpreLbl + +aspRangeLbl _macroRangeLbl = sppRangeLbl `ext` _macroRangeLbl + + + +aspCst1Exp _macroCst1Exp = _macroCst1Exp + + + + +---- Semantic Functions + +l2t1 = mkL2' aspCase aspCaseL_Cons aspCaseL_Nil + aspCaseStmt aspCst1Exp aspDownto aspExpreLbl + aspForStmt aspLabelL_Cons aspLabelL_Nil aspRangeLbl aspTo + + L1.aspAssigStmt L1.aspBoolBOpExp L1.aspBoolExp L1.aspCondStmt L1.aspCondStmtL_Cons L1.aspCondStmtL_Nil + L1.aspIfStmt L1.aspIdExp L1.aspIntBOpExp L1.aspIntCmpExp L1.aspIntExp L1.aspSeqStmt L1.aspWhileStmt + +mkL1' aspAssigStmt aspBoolBOpExp aspBoolExp aspBoolUOpExp aspCondStmt aspCondStmtL_Cons + aspCondStmtL_Nil aspCstDecl aspDeclL_Cons aspDeclL_Nil aspDecls aspEmptyStmt + aspIdExp aspIdentL_Cons aspIdentL_Nil aspIfStmt aspIntBOpExp aspIntCmpExp aspIntExp + aspIntUOpExp aspMaybeElseStmt_Just aspMaybeElseStmt_Nothing aspModule aspParExp + aspSeqStmt aspTypDecl aspType aspVarDecl aspWhileStmt + = mkL1 aspAssigStmt aspBoolBOpExp aspBoolExp aspBoolUOpExp aspCondStmt aspCondStmtL_Cons + aspCondStmtL_Nil aspCstDecl aspDeclL_Cons aspDeclL_Nil + aspDecls aspEmptyStmt + aspIdExp aspIdentL_Cons aspIdentL_Nil aspIfStmt aspIntBOpExp aspIntCmpExp aspIntExp + aspIntUOpExp aspMaybeElseStmt_Just aspMaybeElseStmt_Nothing aspModule aspParExp + aspSeqStmt aspTypDecl aspType (sppVarDecl' `ext` aspVarDecl) aspWhileStmt + +l1t1 = mkL1' L1.aspAssigStmt L1.aspBoolBOpExp L1.aspBoolExp L1.aspBoolUOpExp L1.aspCondStmt L1.aspCondStmtL_Cons + L1.aspCondStmtL_Nil L1.aspCstDecl L1.aspDeclL_Cons L1.aspDeclL_Nil L1.aspDecls L1.aspEmptyStmt + L1.aspIdExp L1.aspIdentL_Cons L1.aspIdentL_Nil L1.aspIfStmt L1.aspIntBOpExp L1.aspIntCmpExp L1.aspIntExp + L1.aspIntUOpExp L1.aspMaybeElseStmt_Just L1.aspMaybeElseStmt_Nothing L1.aspModule L1.aspParExp + L1.aspSeqStmt L1.aspTypDecl L1.aspType L1.aspVarDecl L1.aspWhileStmt + + diff --git a/src/Language/Oberon0/L2/SemT2.hs b/src/Language/Oberon0/L2/SemT2.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L2/SemT2.hs @@ -0,0 +1,108 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-} + +module Language.Oberon0.L2.SemT2 (module Language.Oberon0.L2.SemT2, module Language.Oberon0.L1.SemT2) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..),Pos) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import qualified Data.Map as Map + +import Language.Oberon0.L2.Decl + +import qualified Language.Oberon0.L2.SemT1 as T1 + +import qualified Language.Oberon0.L1.SemT2 as L1 +import Language.Oberon0.L1.SemT2 (spp,sppl,sidl,senv,ienv,serr,spos,SymbolInfo(..),NameDef(..),NInfo,checkName) + + +---- T2 (L2) Name binding + +-- senv + +senvNT = L1.senvNT + +-- ienv + +ienvNT = nt_CaseL .*. nt_Case .*. nt_LabelL .*. nt_Label .*. L1.ienvNT + +ienvIni = L1.ienvIni + +fenv :: r -> (Map.Map String (NInfo r) -> Map.Map String (NInfo r)) + -> (Map.Map String (NInfo r) -> Map.Map String (NInfo r)) +fenv r = id + +ienvForStmt r = inhupdM ienv ienvNT $ do id <- at ch_id_ForStmt + let fid = value id + return $ ch_start_ForStmt .=. fenv r (\env -> Map.delete fid env) .*. + ch_stop_ForStmt .=. fenv r (\env -> Map.delete fid env) .*. + ch_step_ForStmt .=. fenv r (\env -> Map.delete fid env) .*. + ch_ss_ForStmt .=. fenv r (\env -> env) .*. + emptyRecord + + +-- serr + +serrNT = nt_CaseL .*. nt_Case .*. nt_Label .*. L1.serrNT + + +serrRule = use serr serrNT (++) ([] :: [String]) + + +serrForStmt = synmodM serr $ do id <- at ch_id_ForStmt + start <- at ch_start_ForStmt + stop <- at ch_stop_ForStmt + step <- at ch_step_ForStmt + ss <- at ch_ss_ForStmt + lhs <- at lhs + return $ checkName id (lhs # ienv) ["Var"] "a FOR statement" ++ + start # serr ++ stop # serr ++ step # serr ++ ss # serr + + + + +---- Aspects + +aspForStmt r _macroForStmt = (ienvForStmt r) `ext` serrForStmt `ext` (T1.aspForStmt _macroForStmt) +aspTo _ = T1.aspTo +aspDownto _ = T1.aspDownto + +aspCaseStmt _ _macroCaseStmt = T1.aspCaseStmt _macroCaseStmt +aspCaseL_Cons _ _macroCaseL_Cons = T1.aspCaseL_Cons _macroCaseL_Cons +aspCaseL_Nil _ _macroCaseL_Nil = T1.aspCaseL_Nil _macroCaseL_Nil +aspCase _ _macroCase = T1.aspCase _macroCase + +aspLabelL_Cons _ _macroLabelL_Cons = T1.aspLabelL_Cons _macroLabelL_Cons +aspLabelL_Nil _ _macroLabelL_Nil = T1.aspLabelL_Nil _macroLabelL_Nil + +aspExpreLbl _ _macroExpreLbl = T1.aspExpreLbl _macroExpreLbl + +aspRangeLbl _ _macroRangeLbl = T1.aspRangeLbl _macroRangeLbl + + + +aspCst1Exp _ _macroCst1Exp = T1.aspCst1Exp _macroCst1Exp + +---- Semantic Functions + +l2t2 = mkL2' (aspCase ()) (aspCaseL_Cons ()) (aspCaseL_Nil ()) + (aspCaseStmt ()) (aspCst1Exp ()) (aspDownto ()) (aspExpreLbl ()) + (aspForStmt ()) (aspLabelL_Cons ()) (aspLabelL_Nil ()) (aspRangeLbl ()) (aspTo ()) + + (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ()) (L1.aspCondStmtL_Nil ()) + (L1.aspIfStmt ()) (L1.aspIdExp ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ()) (L1.aspSeqStmt ()) (L1.aspWhileStmt ()) + +mkL1' = T1.mkL1' + +l1t2 = mkL1' (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspBoolUOpExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ()) + (L1.aspCondStmtL_Nil ()) (L1.aspCstDecl ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ()) (L1.aspDecls ()) (L1.aspEmptyStmt ()) + (L1.aspIdExp ()) (L1.aspIdentL_Cons ()) (L1.aspIdentL_Nil ()) (L1.aspIfStmt ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ()) + (L1.aspIntUOpExp ()) (L1.aspMaybeElseStmt_Just ()) (L1.aspMaybeElseStmt_Nothing ()) (L1.aspModule ()) (L1.aspParExp ()) + (L1.aspSeqStmt ()) (L1.aspTypDecl ()) (L1.aspType ()) (L1.aspVarDecl ()) (L1.aspWhileStmt ()) + + diff --git a/src/Language/Oberon0/L2/SemT3.hs b/src/Language/Oberon0/L2/SemT3.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L2/SemT3.hs @@ -0,0 +1,95 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction #-} + +module Language.Oberon0.L2.SemT3 (module Language.Oberon0.L2.SemT3, module Language.Oberon0.L1.SemT3) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..),Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import Data.List + + +import Language.Oberon0.L2.Decl +import qualified Language.Oberon0.L2.SemT2 as T2 + + +import qualified Language.Oberon0.L1.SemT3 as L1 +import Language.Oberon0.L1.SemT3 (spp,sidl,sval,senv,ienv,serr,spos,sty,sterr,check,SymbolInfo(..),NameDef(..),TInfo(..),baseType,intType,boolType,unkType,findType) + + +---- T3 (L2) Type-checking + +styNT = L1.styNT +svalNT = L1.svalNT +senvNT = L1.senvNT +ienvNT = L1.ienvNT +ienvIni = L1.ienvIni + +-- sterr + +sterrNT = nt_CaseL .*. nt_Case .*. nt_Label .*. L1.sterrNT + +sterrRule = use sterr sterrNT (++) ([] :: [String]) + + +sterrForStmt = synmodM sterr $ do id <- at ch_id_ForStmt + start <- at ch_start_ForStmt + stop <- at ch_stop_ForStmt + step <- at ch_step_ForStmt + ss <- at ch_ss_ForStmt + lhs <- at lhs + return $ check (pos id) intType (findType (value id) (lhs # ienv)) ++ + check (start # spos) intType (start # sty) ++ + check (stop # spos) intType (stop # sty) ++ + check (step # spos) intType (step # sty) ++ + start # sterr ++ stop # sterr ++ step # sterr ++ ss # sterr + + + + + +---- Aspects +pTInfo :: a -> SymbolInfo TInfo a +pTInfo _ = undefined + +aspForStmt r _macroForStmt = sterrForStmt `ext` (T2.aspForStmt (pTInfo r) _macroForStmt) +aspTo r = T2.aspTo (pTInfo r) +aspDownto r = T2.aspDownto (pTInfo r) + +aspCaseStmt r _macroCaseStmt = T2.aspCaseStmt (pTInfo r) _macroCaseStmt +aspCaseL_Cons r _macroCaseL_Cons = T2.aspCaseL_Cons (pTInfo r) _macroCaseL_Cons +aspCaseL_Nil r _macroCaseL_Nil = T2.aspCaseL_Nil (pTInfo r) _macroCaseL_Nil +aspCase r _macroCase = T2.aspCase (pTInfo r) _macroCase + +aspLabelL_Cons r _macroLabelL_Cons = T2.aspLabelL_Cons (pTInfo r) _macroLabelL_Cons +aspLabelL_Nil r _macroLabelL_Nil = T2.aspLabelL_Nil (pTInfo r) _macroLabelL_Nil + +aspExpreLbl r _macroExpreLbl = T2.aspExpreLbl (pTInfo r) _macroExpreLbl +aspRangeLbl r _macroRangeLbl = T2.aspRangeLbl (pTInfo r) _macroRangeLbl + + + +aspCst1Exp r _macroCst1Exp = T2.aspCst1Exp (pTInfo r) _macroCst1Exp + +---- Semantic Functions + +l2t3 = mkL2' (aspCase ()) (aspCaseL_Cons ()) (aspCaseL_Nil ()) + (aspCaseStmt ()) (aspCst1Exp ()) (aspDownto ()) (aspExpreLbl ()) + (aspForStmt ()) (aspLabelL_Cons ()) (aspLabelL_Nil ()) (aspRangeLbl ()) (aspTo ()) + + (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ()) (L1.aspCondStmtL_Nil ()) + (L1.aspIfStmt ()) (L1.aspIdExp ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ()) (L1.aspSeqStmt ()) (L1.aspWhileStmt ()) + +mkL1' = T2.mkL1' + +l1t3 = mkL1' (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspBoolUOpExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ()) + (L1.aspCondStmtL_Nil ()) (L1.aspCstDecl ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ()) (L1.aspDecls ()) (L1.aspEmptyStmt ()) + (L1.aspIdExp ()) (L1.aspIdentL_Cons ()) (L1.aspIdentL_Nil ()) (L1.aspIfStmt ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ()) + (L1.aspIntUOpExp ()) (L1.aspMaybeElseStmt_Just ()) (L1.aspMaybeElseStmt_Nothing ()) (L1.aspModule ()) (L1.aspParExp ()) + (L1.aspSeqStmt ()) (L1.aspTypDecl ()) (L1.aspType ()) (L1.aspVarDecl ()) (L1.aspWhileStmt ()) + diff --git a/src/Language/Oberon0/L2/SemT5.hs b/src/Language/Oberon0/L2/SemT5.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L2/SemT5.hs @@ -0,0 +1,78 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction #-} + +module Language.Oberon0.L2.SemT5 (module Language.Oberon0.L2.SemT5, module Language.Oberon0.L1.SemT5) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..),Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import Data.List + + +import Language.Oberon0.L2.Decl +import qualified Language.Oberon0.L2.SemT3 as T3 + + +import qualified Language.Oberon0.L1.SemT5 as L1 +import Language.Oberon0.L1.SemT5 (spp,sidl,senv,ienv,serr,spos,sty,sterr,check,SymbolInfo(..),NameDef(..),TInfo(..),baseType,intType,boolType,unkType,findType + ,scgen,scdecl,scty,scexp,scstmt,ipre,mapIdent,updMap,compStmt) + + +---- T5 (L2) Code Generation + +ipreNT = L1.ipreNT +senvNT = L1.senvNT +ienvNT = L1.ienvNT +ienvIni = L1.ienvIni + + +scdeclNT = L1.scdeclNT +scexpNT = L1.scexpNT +scstmtNT = L1.scstmtNT + +---- Aspects +pMap :: a -> SymbolInfo String a +pMap _ = undefined + +aspForStmt r _macroForStmt = T3.aspForStmt (pMap r) _macroForStmt +aspTo r = T3.aspTo (pMap r) +aspDownto r = T3.aspDownto (pMap r) + +aspCaseStmt r _macroCaseStmt = T3.aspCaseStmt (pMap r) _macroCaseStmt +aspCaseL_Cons r _macroCaseL_Cons = T3.aspCaseL_Cons (pMap r) _macroCaseL_Cons +aspCaseL_Nil r _macroCaseL_Nil = T3.aspCaseL_Nil (pMap r) _macroCaseL_Nil +aspCase r _macroCase = T3.aspCase (pMap r) _macroCase + +aspLabelL_Cons r _macroLabelL_Cons = T3.aspLabelL_Cons (pMap r) _macroLabelL_Cons +aspLabelL_Nil r _macroLabelL_Nil = T3.aspLabelL_Nil (pMap r) _macroLabelL_Nil + +aspExpreLbl r _macroExpreLbl = T3.aspExpreLbl (pMap r) _macroExpreLbl +aspRangeLbl r _macroRangeLbl = T3.aspRangeLbl (pMap r) _macroRangeLbl + + + +aspCst1Exp r _macroCst1Exp = T3.aspCst1Exp (pMap r) _macroCst1Exp + +---- Semantic Functions + +l2t5 = mkL2' (aspCase ()) (aspCaseL_Cons ()) (aspCaseL_Nil ()) + (aspCaseStmt ()) (aspCst1Exp ()) (aspDownto ()) (aspExpreLbl ()) + (aspForStmt ()) (aspLabelL_Cons ()) (aspLabelL_Nil ()) (aspRangeLbl ()) (aspTo ()) + + (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ()) (L1.aspCondStmtL_Nil ()) + (L1.aspIfStmt ()) (L1.aspIdExp ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ()) (L1.aspSeqStmt ()) (L1.aspWhileStmt ()) + +mkL1' = T3.mkL1' + +l1t5 = mkL1' (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspBoolUOpExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ()) + (L1.aspCondStmtL_Nil ()) (L1.aspCstDecl ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ()) (L1.aspDecls ()) (L1.aspEmptyStmt ()) + (L1.aspIdExp ()) (L1.aspIdentL_Cons ()) (L1.aspIdentL_Nil ()) (L1.aspIfStmt ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ()) + (L1.aspIntUOpExp ()) (L1.aspMaybeElseStmt_Just ()) (L1.aspMaybeElseStmt_Nothing ()) (L1.aspModule ()) (L1.aspParExp ()) + (L1.aspSeqStmt ()) (L1.aspTypDecl ()) (L1.aspType ()) (L1.aspVarDecl ()) (L1.aspWhileStmt ()) + + diff --git a/src/Language/Oberon0/L2/T1.hs b/src/Language/Oberon0/L2/T1.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L2/T1.hs @@ -0,0 +1,14 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.MainT1 +import Language.Oberon0.L2.Gram +import Language.Oberon0.L2.SemT1 + + +import Language.Grammars.Murder +import Language.Grammars.AspectAG + + +c_l2t1 = closeGram (l1 l1t1 +>> l2 l2t1) + +main = mainT1 (# spp) emptyRule "l2t1" l2Kws c_l2t1 diff --git a/src/Language/Oberon0/L2/T2.hs b/src/Language/Oberon0/L2/T2.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L2/T2.hs @@ -0,0 +1,17 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.L2.Gram +import Language.Oberon0.L2.SemT2 +import Language.Oberon0.MainT2 + +import Language.Grammars.Murder +import Language.Grammars.Murder.UUParsing + +import Language.Grammars.AspectAG + + +c_l2t2 = closeGram (l1 l1t2 +>> l2 l2t2) + + +main = mainT2 (# spp) (# serr) (ienv .=. ienvIni () .*. emptyRecord) "l2t2" l2Kws c_l2t2 + diff --git a/src/Language/Oberon0/L2/T3.hs b/src/Language/Oberon0/L2/T3.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L2/T3.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.L2.Gram +import Language.Oberon0.L2.SemT3 +import Language.Oberon0.MainT2 + +import Language.Grammars.Murder +import Language.Grammars.AspectAG + + +c_l2t3 = closeGram (l1 l1t3 +>> l2 l2t3) + + +main = mainT2 (# spp) (# serr) (ienv .=. ienvIni () .*. emptyRecord) "l2t3" l2Kws c_l2t3 + diff --git a/src/Language/Oberon0/L2/T5.hs b/src/Language/Oberon0/L2/T5.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L2/T5.hs @@ -0,0 +1,18 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.L2.Gram +import Language.Oberon0.L2.SemT5 +import Language.Oberon0.MainT5 + +import Language.Grammars.Murder +import Language.Grammars.Murder.UUParsing + +import Language.Grammars.AspectAG + + +c_l2t5 = closeGram (l1 l1t5 +>> l2 l2t5) + + +main = mainT5 (# spp) (# serr) (# scgen) (ienv .=. ienvIni () .*. emptyRecord) "l2t5" l2Kws c_l2t5 + + diff --git a/src/Language/Oberon0/L3/Decl.hs b/src/Language/Oberon0/L3/Decl.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L3/Decl.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-} + +module Language.Oberon0.L3.Decl (module Language.Oberon0.L2.Decl, module Language.Oberon0.L3.Decl) where + +import Language.Oberon0.L2.Decl + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive + + +---- L3 Grammar + +-- Procedure + +type ParamL = [Param] + +type GHC_KindParam = KindParam; data KindParam = VarP | ValP deriving Eq + +instance Show KindParam where + show VarP = "VAR" + show ValP = "" + +data Param + = Param { kind_Param :: GHC_KindParam, idl_Param :: IdentL, typ_Param :: Type } + +data EXT_Decl + = ProcDecl { id_ProcDecl :: String, params_ProcDecl :: ParamL, decls_ProcDecl :: Declarations + , stmts_ProcDecl :: Statement, idend_ProcDecl :: String } + +data EXT_Declarations + = ExtDeclarations { decls_ExtDeclarations :: Declarations, prcdecl_ExtDeclarations :: DeclL } + + +$(extendAG ''EXT_Decl [''Declarations,''Statement,''IdentL, ''Type]) +$(extendAG ''EXT_Declarations [''Declarations,''DeclL]) + +type ExpressionL = [Expression] + +data EXT2_Statement + = ProcCStmt { id_ProcCStmt :: String, params_ProcCStmt :: ExpressionL } + + +$(extendAG ''EXT2_Statement [''Expression]) + + +data L3SF ed1 ed2 ed pd1 pd2 pd3 pd4 pd5 pd plc1 plc2 pl pln + p1 p2 p3 p pcs1 pcs2 pcs elc1 elc2 elc eln + es dlc1 dlc2 dlc dln + = L3SF + { pExtDeclarations :: ed1 -> ed2 -> ed + , pProcDecl :: pd1 -> pd2 -> pd3 -> pd4 -> pd5 -> pd + + , pParamL_Cons :: plc1 -> plc2 -> pl + , pParamL_Nil :: pln + + , pParam :: p1 -> p2 -> p3 -> p + + , pProcCStmt :: pcs1 -> pcs2 -> pcs + + , pExpressionL_Cons :: elc1 -> elc2 -> elc + , pExpressionL_Nil :: eln + + --from L1 + , pEmptyStmt' :: es + , pDeclL_Cons' :: dlc1 -> dlc2 -> dlc + , pDeclL_Nil' :: dln + + } + + + +mkL3 _aspExtDeclarations _aspProcDecl _aspParamL_Cons _aspParamL_Nil _aspParam + _aspProcCStmt _aspExpressionL_Cons _aspExpressionL_Nil + + _aspEmptyStmt _aspDeclL_Cons _aspDeclL_Nil + + = L3SF + { pExtDeclarations = semP_ExtDeclarations _aspExtDeclarations + , pProcDecl = semP_ProcDecl _aspProcDecl + + , pParamL_Cons = semP_ParamL_Cons _aspParamL_Cons + , pParamL_Nil = semP_ParamL_Nil _aspParamL_Nil + + , pParam = semP_Param _aspParam + + , pProcCStmt = semP_ProcCStmt _aspProcCStmt + + , pExpressionL_Cons = semP_ExpressionL_Cons _aspExpressionL_Cons + , pExpressionL_Nil = semP_ExpressionL_Nil _aspExpressionL_Nil + + --from L1 + , pEmptyStmt' = semP_EmptyStmt _aspEmptyStmt + , pDeclL_Cons' = semP_DeclL_Cons _aspDeclL_Cons + , pDeclL_Nil' = semP_DeclL_Nil _aspDeclL_Nil + + } + diff --git a/src/Language/Oberon0/L3/Gram.hs b/src/Language/Oberon0/L3/Gram.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L3/Gram.hs @@ -0,0 +1,60 @@ +{-# OPTIONS -fcontext-stack=100 #-} + +{-# LANGUAGE Arrows, DoRec #-} + +module Language.Oberon0.L3.Gram (module Language.Oberon0.L3.Gram, module Language.Oberon0.L2.Gram) where + +import Language.Oberon0.L2.Gram +import Language.Oberon0.L3.Decl + +import Control.Arrow +import Control.Applicative +import Data.Set (union,fromList) + +import Language.Grammars.Murder +import Language.Grammars.Grammar + +import Language.Grammars.AspectAG + +fpVar sf = pParam sf (sem_Lit VarP) +fpVal sf = pParam sf (sem_Lit ValP) + +l3 sf = proc imported -> do + let decls = getNT cs_Declarations imported + let statement = getNT cs_Statement imported + let ss = getNT cs_StatementSequence imported + let exp = getNT cs_Expression imported + let ident = getNT cs_Ident imported + let idl = getNT cs_IdentL imported + let typ = getNT cs_Type imported + + + rec addProds -< (statement, iI (pProcCStmt sf) ident params Ii) + + params <- addNT -< iI "(" paraml ")" Ii + <|> iI (pExpressionL_Nil sf) Ii + + paraml <- addNT -< iI (pExpressionL_Cons sf) exp (pFoldr (pExpressionL_Cons sf, pExpressionL_Nil sf) (iI "," exp Ii)) Ii + <|> iI (pExpressionL_Nil sf) Ii + + updProds -< (decls, \declarations -> iI (pExtDeclarations sf) declarations procDeclL Ii) + + procDeclL <- addNT -< pFoldr (pDeclL_Cons' sf, pDeclL_Nil' sf) (iI procDecl Ii) + + procDecl <- addNT -< iI (pProcDecl sf) "PROCEDURE" ident fparams ";" + decls + (pMaybe (pEmptyStmt' sf, id) (iI "BEGIN" ss Ii)) + "END" ident ";" Ii + + fparams <- addNT -< iI "(" fparaml ")" Ii + <|> iI (pParamL_Nil sf) Ii + + fparaml <- addNT -< iI (pParamL_Cons sf) fparam (pFoldr (pParamL_Cons sf, pParamL_Nil sf) (iI ";" fparam Ii)) Ii + <|> iI (pParamL_Nil sf) Ii + + fparam <- addNT -< iI (fpVar sf) "VAR" idl ":" typ Ii <|> iI (fpVal sf) idl ":" typ Ii + + exportNTs -< imported + +l3Kws = union l2Kws $ fromList ["PROCEDURE"] + diff --git a/src/Language/Oberon0/L3/SemT1.hs b/src/Language/Oberon0/L3/SemT1.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L3/SemT1.hs @@ -0,0 +1,115 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-} + +module Language.Oberon0.L3.SemT1 (module Language.Oberon0.L3.SemT1, module Language.Oberon0.L2.SemT1) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..), Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import UU.Pretty + +import Language.Oberon0.L3.Decl + +import Language.Oberon0.L1.SemT1 (aspEmptyStmt, aspDeclL_Cons, aspDeclL_Nil) + +import qualified Language.Oberon0.L2.SemT1 as L2 +import Language.Oberon0.L2.SemT1 (l1t1,l2t1,spp,sppl,sidl) + + + + + +---- T1(L3) Pretty-Printing + + +sppNT = nt_Param .*. L2.sppNT + +sppExtDeclarations + = syn spp $ do + decls <- at ch_decls_ExtDeclarations + prcdecl <- at ch_prcdecl_ExtDeclarations + return $ decls # spp >-< + vlist (prcdecl # sppl) + + + +sppParam + = syn spp $ do + kind <- at ch_kind_Param + idl <- at ch_idl_Param + typ <- at ch_typ_Param + + return $ case (map pp (idl # sidl)) of + [] -> empty + ppidl -> show kind >#< pp_block "" "" ", " ppidl >#< ":" >#< typ # spp + +sppProcDecl + = syn spp $ do + id <- at ch_id_ProcDecl + params <- at ch_params_ProcDecl + decls <- at ch_decls_ProcDecl + stmts <- at ch_stmts_ProcDecl + idend <- at ch_idend_ProcDecl + + return $ "PROCEDURE" >#< value id >#< pp_block "(" ")" ";" (params # sppl) >#< ";" >-< + decls # spp >-< pp_block " BEGIN " (" END " ++ value idend ++ ";") ";" (stmts # sppl) + + +-- sppl + +spplNT = nt_ExpressionL .*. nt_ParamL .*. L2.spplNT + +spplProcCStmt + = syn sppl $ do + id <- at ch_id_ProcCStmt + params <- at ch_params_ProcCStmt + return $ [ value id >#< pp_block "(" ")" "," (params # sppl) ] + + +spplParamL_Cons + = syn sppl $ do hd <- at ch_hd_ParamL_Cons + tl <- at ch_tl_ParamL_Cons + return $ (hd # spp) : (tl # sppl) + +spplParamL_Nil + = syn sppl $ do return $ [] + + +spplExpressionL_Cons + = syn sppl $ do h <- at ch_hd_ExpressionL_Cons + t <- at ch_tl_ExpressionL_Cons + return $ (h # spp) : (t # sppl) +spplExpressionL_Nil + = syn sppl $ do return $ ([] :: [PP_Doc]) + + +---- Aspects + +aspExtDeclarations = sppExtDeclarations + +aspProcDecl = sppProcDecl + +aspParamL_Cons = spplParamL_Cons +aspParamL_Nil = spplParamL_Nil + +aspParam = sppParam + +aspProcCStmt = spplProcCStmt + +aspExpressionL_Cons = spplExpressionL_Cons +aspExpressionL_Nil = spplExpressionL_Nil + +---- Semantic Functions + + + +l3t1 = mkL3 aspExtDeclarations aspProcDecl aspParamL_Cons aspParamL_Nil aspParam + aspProcCStmt aspExpressionL_Cons aspExpressionL_Nil + aspEmptyStmt aspDeclL_Cons aspDeclL_Nil + + diff --git a/src/Language/Oberon0/L3/SemT2.hs b/src/Language/Oberon0/L3/SemT2.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L3/SemT2.hs @@ -0,0 +1,117 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction, ScopedTypeVariables #-} + +module Language.Oberon0.L3.SemT2 (module Language.Oberon0.L3.SemT2, module Language.Oberon0.L2.SemT2) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..),Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import qualified Data.Map as Map + +import Language.Oberon0.L1.SemT2 (aspEmptyStmt, aspDeclL_Cons, aspDeclL_Nil) + + +import Language.Oberon0.L3.Decl + +import qualified Language.Oberon0.L3.SemT1 as T1 + + +import qualified Language.Oberon0.L2.SemT2 as L2 +import Language.Oberon0.L2.SemT2 (l1t2,l2t2,spp,sppl,sidl,senv,ienv,serr,spos,SymbolInfo(..),NameDef(..),NInfo,checkName) + + +---- T2 (L3) Name binding + + +-- senv + +senvNT = nt_Param .*. nt_ParamL .*. L2.senvNT + +senvRule (_ :: a) = use senv senvNT Map.union (Map.empty :: Map.Map String (NInfo a)) + + +senvProcDecl r + = syn senv $ do id <- at ch_id_ProcDecl + return $ Map.singleton (value id) + (SI (NameDef (pos id) "Prc" "procedure") r) + + +-- ienv + +ienvNT = nt_Param .*. nt_ParamL .*. nt_ExpressionL .*. L2.ienvNT + +ienvRule _ = copy ienv ienvNT + + +stdProcs r = Map.fromList [ ("Read", SI (NameDef (Pos (-1) (-1)) "Prc" "standard procedure") r) + , ("Write", SI (NameDef (Pos (-1) (-1)) "Prc" "standard procedure") r) + , ("WriteLn", SI (NameDef (Pos (-1) (-1)) "Prc" "standard procedure") r) ] + +ienvIni r = Map.union (L2.ienvIni r) (stdProcs r) + +ienvExtDeclarations r + = inh ienv ienvNT $ do + lhs <- at lhs + decls <- at ch_decls_ExtDeclarations + prcdecl <- at ch_prcdecl_ExtDeclarations + + let local = Map.union (Map.filter (\(SI (NameDef _ k _) _) -> k /= "Var") (decls # senv)) (prcdecl # senv) + let env = Map.union local (lhs # ienv) + return $ ch_decls_ExtDeclarations .=. Map.union (decls # senv) (lhs # ienv) .*. + ch_prcdecl_ExtDeclarations .=. env .*. + emptyRecord + +ienvProcDecl _ + = inh ienv ienvNT $ do + lhs <- at lhs + params <- at ch_params_ProcDecl + decls <- at ch_decls_ProcDecl + stmts <- at ch_stmts_ProcDecl + + let local = Map.union (params # senv) (decls # senv) + env = Map.union local (lhs # ienv) + return $ ch_params_ProcDecl .=. Map.union (params # senv) (lhs # ienv) .*. + ch_stmts_ProcDecl .=. env .*. + ch_decls_ProcDecl .=. (lhs # ienv) .*. + emptyRecord + + +-- serr + +serrNT = nt_Param .*. nt_ParamL .*. nt_ExpressionL .*. L2.serrNT + + +serrRule = use serr serrNT (++) ([] :: [String]) + + +serrProcCStmt + = syn serr $ do id <- at ch_id_ProcCStmt + params <- at ch_params_ProcCStmt + lhs <- at lhs + return $ checkName id (lhs # ienv) ["Prc"] "a procedure call" ++ params # serr + + + +---- Aspects + +aspExtDeclarations r = (senvRule r) `ext` (ienvExtDeclarations r) `ext` serrRule `ext` T1.aspExtDeclarations +aspProcDecl r = (senvProcDecl r) `ext` (ienvProcDecl r) `ext` serrRule `ext` T1.aspProcDecl +aspParamL_Cons r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspParamL_Cons +aspParamL_Nil r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspParamL_Nil +aspParam r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspParam +aspProcCStmt r = (ienvRule r) `ext` serrProcCStmt `ext` T1.aspProcCStmt +aspExpressionL_Cons r = (ienvRule r) `ext` serrRule `ext` T1.aspExpressionL_Cons +aspExpressionL_Nil r = (ienvRule r) `ext` serrRule `ext` T1.aspExpressionL_Nil + + +---- Semantic Functions + +l3t2 = mkL3 (aspExtDeclarations ()) (aspProcDecl ()) (aspParamL_Cons ()) (aspParamL_Nil ()) (aspParam ()) + (aspProcCStmt ()) (aspExpressionL_Cons ()) (aspExpressionL_Nil ()) + (aspEmptyStmt ()) (aspDeclL_Cons ()) (aspDeclL_Nil ()) + diff --git a/src/Language/Oberon0/L3/SemT3.hs b/src/Language/Oberon0/L3/SemT3.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L3/SemT3.hs @@ -0,0 +1,209 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction, TemplateHaskell, DeriveDataTypeable #-} + +module Language.Oberon0.L3.SemT3 (module Language.Oberon0.L3.SemT3, module Language.Oberon0.L2.SemT3) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..),Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import qualified Data.Map as Map +import Data.Dynamic + +import qualified Language.Oberon0.L1.SemT3 as L1 -- (aspEmptyStmt, aspDeclL_Cons, aspDeclL_Nil) + + +import Language.Oberon0.L3.Decl + +import qualified Language.Oberon0.L3.SemT2 as T2 +--import L3.SemT2 (DeclDef(..)) + + +import qualified Language.Oberon0.L2.SemT3 as L2 +import Language.Oberon0.L2.SemT3 (mkL1',spp,sidl,sval,senv,ienv,serr,spos,sty,sterr,check,SymbolInfo(..),NameDef(..),TInfo(..),baseType,intType,boolType,unkType,findType) + + +---- T3 (L3) Type-checking + +data ProcType = ProcType [ ParamInfo ] deriving (Typeable, Show) + +data ParamInfo = ParamInfo Pos KindParam TInfo deriving (Typeable, Show) + +procType ps = let t = (ProcType ps) + in TInfo (toDyn t) (show t) ((\t2 -> teq t2 unkType) . baseType) + +-- sknd +$(attLabels ["sknd"]) + +skndNT = nt_Expression .*. hNil + +skndRule = use sknd skndNT (\_ _ -> ValP) ValP + +skndIdExp = syn sknd $ do id <- at ch_id_IdExp + lhs <- at lhs + return $ case (Map.lookup (value id) (lhs # ienv)) of + Just (SI (NameDef _ t _) _) -> case t of + "Var" -> VarP + _ -> ValP + Nothing -> ValP + + +-- spl + +$(attLabels ["spl"]) + + +splNT = nt_Param .*. nt_ParamL .*. nt_ExpressionL .*. hNil + +splRule = use spl splNT (++) ([] :: [ParamInfo]) + +splExpressionL_Cons = syn spl $ do h <- at ch_hd_ExpressionL_Cons + t <- at ch_tl_ExpressionL_Cons + return $ (ParamInfo (h # spos) (h # sknd) (h # sty)) : (t # spl) +splExpressionL_Nil = syn spl $ do return $ ([] :: [ParamInfo]) + + +splParam = syn spl $ do knd <- at ch_kind_Param + idl <- at ch_idl_Param + typ <- at ch_typ_Param + return $ map (const (ParamInfo (Pos 0 0) knd (typ # sty))) (idl # sidl) + +-- sty + +styNT = L2.styNT + + +-- sval + +svalNT = L2.svalNT + +-- senv + + +senvNT = nt_ParamL .*. nt_Param .*. L2.senvNT + + +senvParam' r = synupdM senv $ do typ <- at ch_typ_Param + return $ Map.map (\(SI nd _) -> (SI nd (SI (typ # sty) r))) + +senvProcDecl' r = synupdM senv $ do id <- at ch_id_ProcDecl + params <- at ch_params_ProcDecl + return $ Map.map (\(SI nd _) -> (SI nd (SI (procType (params # spl)) r))) + +-- ienv + +ienvNT = L2.ienvNT + +stdPos = Pos (-1) (-1) +stdProcs r = Map.fromList [ ("Read", SI (NameDef stdPos "Prc" "standard procedure") + (SI (procType [ParamInfo stdPos VarP intType ]) r)) + , ("Write", SI (NameDef stdPos "Prc" "standard procedure") + (SI (procType [ParamInfo stdPos ValP intType ]) r)) + , ("WriteLn", SI (NameDef stdPos "Prc" "standard procedure") + (SI (procType [ ]) r)) ] + +ienvIni r = Map.union (L2.ienvIni r) (stdProcs r) + + + +-- sterr + +sterrNT = nt_Param .*. nt_ParamL .*. nt_ExpressionL .*. L2.sterrNT + + +sterrRule = use sterr sterrNT (++) ([] :: [String]) + + +checkK pos expected got = if (expected == VarP) && (expected /= got) + then [ show pos ++ ": Illegal parameter. Variable expected" ] + else [] + + +sterrProcCStmt + = syn sterr $ do id <- at ch_id_ProcCStmt + params <- at ch_params_ProcCStmt + lhs <- at lhs + let callpts = params # spl + let pid = value id + return $ case (fromDynamic . trep . findType pid) (lhs # ienv) of + Just (ProcType exppts) -> let lcallpts = length callpts + lexppts = length exppts + numerr = if lcallpts == lexppts + then [] + else [ show (pos id) ++ ": Wrong number of parameters. Procedure " ++ pid ++ + " expects " ++ show lexppts ++ ", but got " ++ show lcallpts ] + perr = zipWith (\(ParamInfo p gk gt) (ParamInfo _ k t) -> check p t gt ++ checkK p k gk) callpts exppts + in numerr ++ concat perr + _ -> [] + + + + + +---- Aspects +pTInfo :: a -> SymbolInfo TInfo a +pTInfo _ = undefined + +aspExtDeclarations r = sterrRule `ext` (T2.aspExtDeclarations (pTInfo r)) +aspProcDecl r = (senvProcDecl' r) `ext` sterrRule `ext` (T2.aspProcDecl (pTInfo r)) +aspParamL_Cons r = splRule `ext` sterrRule `ext` (T2.aspParamL_Cons (pTInfo r)) +aspParamL_Nil r = splRule `ext` sterrRule `ext` (T2.aspParamL_Nil (pTInfo r)) +aspParam r = splParam `ext` (senvParam' r) `ext` sterrRule `ext` (T2.aspParam (pTInfo r)) +aspProcCStmt r = sterrProcCStmt `ext` (T2.aspProcCStmt (pTInfo r)) +aspExpressionL_Cons r = splExpressionL_Cons `ext` sterrRule `ext` (T2.aspExpressionL_Cons (pTInfo r)) +aspExpressionL_Nil r = splExpressionL_Nil `ext` sterrRule `ext` (T2.aspExpressionL_Nil (pTInfo r)) + + +---- Semantic Functions + +mkL1'' aspAssigStmt aspBoolBOpExp aspBoolExp aspBoolUOpExp aspCondStmt aspCondStmtL_Cons + aspCondStmtL_Nil aspCstDecl aspDeclL_Cons aspDeclL_Nil aspDecls aspEmptyStmt + aspIdExp aspIdentL_Cons aspIdentL_Nil aspIfStmt aspIntBOpExp aspIntCmpExp aspIntExp + aspIntUOpExp aspMaybeElseStmt_Just aspMaybeElseStmt_Nothing aspModule aspParExp + aspSeqStmt aspTypDecl aspType aspVarDecl aspWhileStmt + = mkL1' aspAssigStmt (skndRule `ext` aspBoolBOpExp) (skndRule `ext` aspBoolExp) + (skndRule `ext` aspBoolUOpExp) aspCondStmt aspCondStmtL_Cons + aspCondStmtL_Nil aspCstDecl aspDeclL_Cons aspDeclL_Nil aspDecls aspEmptyStmt + (skndIdExp `ext` aspIdExp) aspIdentL_Cons aspIdentL_Nil aspIfStmt (skndRule `ext` aspIntBOpExp) + (skndRule `ext` aspIntCmpExp) (skndRule `ext` aspIntExp) + (skndRule `ext` aspIntUOpExp) aspMaybeElseStmt_Just aspMaybeElseStmt_Nothing aspModule + (skndRule `ext` aspParExp) aspSeqStmt aspTypDecl aspType aspVarDecl aspWhileStmt + + +mkL2'' _aspCase _aspCaseL_Cons _aspCaseL_Nil + _aspCaseStmt _aspCst1Exp _aspDownto _aspExpreLbl + _aspForStmt _aspLabelL_Cons _aspLabelL_Nil _aspRangeLbl _aspTo + + _aspAssigStmt _aspBoolBOpExp _aspBoolExp _aspCondStmt _aspCondStmtL_Cons _aspCondStmtL_Nil + _aspIfStmt _aspIdExp _aspIntBOpExp _aspIntCmpExp _aspIntExp _aspSeqStmt _aspWhileStmt + + = mkL2' _aspCase _aspCaseL_Cons _aspCaseL_Nil + _aspCaseStmt _aspCst1Exp _aspDownto _aspExpreLbl + _aspForStmt _aspLabelL_Cons _aspLabelL_Nil _aspRangeLbl _aspTo + + _aspAssigStmt (skndRule `ext` _aspBoolBOpExp) (skndRule `ext` _aspBoolExp) + _aspCondStmt _aspCondStmtL_Cons _aspCondStmtL_Nil _aspIfStmt + (skndRule `ext` _aspIdExp) (skndRule `ext` _aspIntBOpExp) (skndRule `ext` _aspIntCmpExp) + (skndRule `ext` _aspIntExp) _aspSeqStmt _aspWhileStmt + +l1t3 = mkL1'' (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspBoolUOpExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ()) + (L1.aspCondStmtL_Nil ()) (L1.aspCstDecl ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ()) (L1.aspDecls ()) (L1.aspEmptyStmt ()) + (L1.aspIdExp ()) (L1.aspIdentL_Cons ()) (L1.aspIdentL_Nil ()) (L1.aspIfStmt ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ()) + (L1.aspIntUOpExp ()) (L1.aspMaybeElseStmt_Just ()) (L1.aspMaybeElseStmt_Nothing ()) (L1.aspModule ()) (L1.aspParExp ()) + (L1.aspSeqStmt ()) (L1.aspTypDecl ()) (L1.aspType ()) (L1.aspVarDecl ()) (L1.aspWhileStmt ()) + +l2t3 = mkL2'' (L2.aspCase ()) (L2.aspCaseL_Cons ()) (L2.aspCaseL_Nil ()) + (L2.aspCaseStmt ()) (L2.aspCst1Exp ()) (L2.aspDownto ()) (L2.aspExpreLbl ()) + (L2.aspForStmt ()) (L2.aspLabelL_Cons ()) (L2.aspLabelL_Nil ()) (L2.aspRangeLbl ()) (L2.aspTo ()) + + (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ()) (L1.aspCondStmtL_Nil ()) + (L1.aspIfStmt ()) (L1.aspIdExp ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ()) (L1.aspSeqStmt ()) (L1.aspWhileStmt ()) + +l3t3 = mkL3 (aspExtDeclarations ()) (aspProcDecl ()) (aspParamL_Cons ()) (aspParamL_Nil ()) (aspParam ()) + (aspProcCStmt ()) (aspExpressionL_Cons ()) (aspExpressionL_Nil ()) + (L1.aspEmptyStmt ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ()) + diff --git a/src/Language/Oberon0/L3/SemT5.hs b/src/Language/Oberon0/L3/SemT5.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L3/SemT5.hs @@ -0,0 +1,219 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction #-} + +module Language.Oberon0.L3.SemT5 (module Language.Oberon0.L3.SemT5, module Language.Oberon0.L2.SemT5) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..),Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import Data.List (partition) +import qualified Data.Map as Map +import Data.Dynamic + +import Language.C + +import qualified Language.Oberon0.L1.SemT5 as L1 -- (aspEmptyStmt, aspDeclL_Cons, aspDeclL_Nil) + + +import Language.Oberon0.L3.Decl + +--import L3.SemT2 (DeclDef(..)) + + +import qualified Language.Oberon0.L3.SemT3 as T3 +import Language.Oberon0.L3.SemT3 (mkL1'',mkL2'',ParamInfo(..),spl,procType,ProcType(..)) + + + +import qualified Language.Oberon0.L2.SemT5 as L2 +import Language.Oberon0.L2.SemT5 (spp,sidl,senv,ienv,serr,spos,sty,sterr,check,SymbolInfo(..),NameDef(..),TInfo(..),baseType,intType,boolType,unkType,findType + ,scgen,scdecl,scty,scexp,scstmt,ipre,mapIdent,updMap,compStmt) + + +---- T5 (L3) Code Generation + +-- ipre + +ipreNT = nt_Param .*. nt_ParamL .*. nt_ExpressionL .*. L2.ipreNT + +ipreRule = copy ipre ipreNT + + +ipreProcDecl = inh ipre ipreNT $ do lhs <- at lhs + id <- at ch_id_ProcDecl + params <- at ch_params_ProcDecl + decls <- at ch_decls_ProcDecl + stmts <- at ch_stmts_ProcDecl + + let pre = (lhs # ipre) ++ "1" ++ (value id) ++ "_" + return $ ch_params_ProcDecl .=. pre .*. + ch_stmts_ProcDecl .=. pre .*. + ch_decls_ProcDecl .=. pre .*. + emptyRecord + +-- senv + + +senvNT = T3.senvNT + + +senvProcDecl' r = synupdM senv $ do lhs <- at lhs + id <- at ch_id_ProcDecl + let pid = value id + return $ Map.adjust (updMap (lhs # ipre ++ pid) r) pid + +senvParam' r = synupdM senv $ do lhs <- at lhs + knd <- at ch_kind_Param + idl <- at ch_idl_Param + let pname i = case knd of + ValP -> updMap (lhs # ipre ++ i) r + VarP -> updMap ("(*" ++ lhs # ipre ++ i ++ ")") r + return $ Map.mapWithKey pname + +-- ienv + +ienvNT = L2.ienvNT + +stdPos = Pos (-1) (-1) +stdProcs r = Map.fromList [ ("Read", SI (NameDef stdPos "Prc" "standard procedure") + (SI (procType [ParamInfo stdPos VarP intType ]) (SI "scanf" r))) + , ("Write", SI (NameDef stdPos "Prc" "standard procedure") + (SI (procType [ParamInfo stdPos ValP intType ]) (SI "printf" r))) + , ("WriteLn", SI (NameDef stdPos "Prc" "standard procedure") + (SI (procType [ ]) (SI "printf" r))) ] + + +ienvIni r = Map.union (L2.ienvIni r) (stdProcs r) + +-- scexp + +scexpNT = L2.scexpNT + +-- scexpl + +$(attLabels ["scexpl"]) + +scexplExpressionL_Cons = syn scexpl $ do h <- at ch_hd_ExpressionL_Cons + t <- at ch_tl_ExpressionL_Cons + return $ (h # scexp) : (t # scexpl) +scexplExpressionL_Nil = syn scexpl $ do return $ ([] :: [CExpression NodeInfo]) + + +-- scdec + +$(attLabels ["scdec"]) + +scdecNT = nt_Param .*. nt_ParamL .*. hNil + +scdecRule = use scdec scdecNT (++) ([] :: [CDeclaration NodeInfo]) + +scdecParam = syn scdec $ do lhs <- at lhs + kind <- at ch_kind_Param + idl <- at ch_idl_Param + typ <- at ch_typ_Param + let (tys,tyd) = typ # scty + return $ map (\name -> ( CDecl [ tys ] + [(Just (CDeclr (Just $ mapIdent name (lhs # ienv)) tyd Nothing [] undefNode),Nothing,Nothing)] + undefNode)) + (idl # sidl) + + +-- scdecl + +scdeclNT = L2.scdeclNT + +scdeclRule = use scdecl scdeclNT (++) ([] :: [CExternalDeclaration NodeInfo]) + +filterVars = partition isNotVar + + +--isNotVar (CTypeQual (CConstQual _):_) = True +isNotVar (CDeclExt (CDecl ts vs _)) = isNotVar' ts vs +isNotVar _ = True + +isNotVar' ts [] = True +isNotVar' (CStorageSpec (CTypedef _):_) _ = True +isNotVar' (_:ts) vs = isNotVar' ts vs +isNotVar' [] _ = False + + +scdeclProcDecl = syn scdecl $ do lhs <- at lhs + id <- at ch_id_ProcDecl + params <- at ch_params_ProcDecl + decls <- at ch_decls_ProcDecl + stmts <- at ch_stmts_ProcDecl + let (nvdecs,vdecs) = filterVars (decls # scdecl) + let procdef = CFDefExt $ CFunDef [ CTypeSpec (CVoidType undefNode) ] + ( CDeclr (Just $ mapIdent (value id) (lhs # ienv)) + [CFunDeclr (Right ((params # scdec),False)) [] undefNode] + Nothing [] undefNode) + [] + (compStmt (CCompound [] (map (\(CDeclExt d)-> CBlockDecl d) vdecs) undefNode) + (stmts # scstmt)) + undefNode + return $ nvdecs ++ [ procdef ] + + +-- scstmt + +scstmtNT = L2.scstmtNT + +scstmtProcCStmt = syn scstmt $ do lhs <- at lhs + id <- at ch_id_ProcCStmt + params <- at ch_params_ProcCStmt + let pid = value id + let desc = case pid of + "Write" -> [CConst $ CStrConst (cString " %d") undefNode] + "WriteLn" -> [CConst $ CStrConst (cString "\n") undefNode] + "Read" -> [CConst $ CStrConst (cString "%d") undefNode] + p -> [] + + let expps = case (fromDynamic . trep . findType pid) (lhs # ienv) of + Just (ProcType ps) -> ps + _ -> [] + let cparams = zipWith (\(ParamInfo _ k _) ce -> if k == VarP then CUnary CAdrOp ce undefNode else ce) + + return $ CExpr (Just (CCall (CVar (mapIdent pid (lhs # ienv)) undefNode) + (desc ++ cparams expps (params # scexpl)) + undefNode)) + undefNode + + + +---- Aspects +pMap :: a -> SymbolInfo String a +pMap _ = undefined + +aspExtDeclarations r = ipreRule `ext` scdeclRule `ext` (T3.aspExtDeclarations (pMap r)) +aspProcDecl r = ipreProcDecl `ext` (senvProcDecl' r) `ext` scdeclProcDecl `ext` (T3.aspProcDecl (pMap r)) +aspParamL_Cons r = ipreRule `ext` scdecRule `ext` (T3.aspParamL_Cons (pMap r)) +aspParamL_Nil r = ipreRule `ext` scdecRule `ext` (T3.aspParamL_Nil (pMap r)) +aspParam r = ipreRule `ext` (senvParam' r) `ext` scdecParam `ext` (T3.aspParam (pMap r)) +aspProcCStmt r = ipreRule `ext` scstmtProcCStmt `ext` (T3.aspProcCStmt (pMap r)) +aspExpressionL_Cons r = ipreRule `ext` scexplExpressionL_Cons `ext` (T3.aspExpressionL_Cons (pMap r)) +aspExpressionL_Nil r = ipreRule `ext` scexplExpressionL_Nil `ext` (T3.aspExpressionL_Nil (pMap r)) + + +---- Semantic Functions + +l1t5 = mkL1'' (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspBoolUOpExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ()) + (L1.aspCondStmtL_Nil ()) (L1.aspCstDecl ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ()) (L1.aspDecls ()) (L1.aspEmptyStmt ()) + (L1.aspIdExp ()) (L1.aspIdentL_Cons ()) (L1.aspIdentL_Nil ()) (L1.aspIfStmt ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ()) + (L1.aspIntUOpExp ()) (L1.aspMaybeElseStmt_Just ()) (L1.aspMaybeElseStmt_Nothing ()) (L1.aspModule ()) (L1.aspParExp ()) + (L1.aspSeqStmt ()) (L1.aspTypDecl ()) (L1.aspType ()) (L1.aspVarDecl ()) (L1.aspWhileStmt ()) + +l2t5 = mkL2'' (L2.aspCase ()) (L2.aspCaseL_Cons ()) (L2.aspCaseL_Nil ()) + (L2.aspCaseStmt ()) (L2.aspCst1Exp ()) (L2.aspDownto ()) (L2.aspExpreLbl ()) + (L2.aspForStmt ()) (L2.aspLabelL_Cons ()) (L2.aspLabelL_Nil ()) (L2.aspRangeLbl ()) (L2.aspTo ()) + + (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ()) (L1.aspCondStmtL_Nil ()) + (L1.aspIfStmt ()) (L1.aspIdExp ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ()) (L1.aspSeqStmt ()) (L1.aspWhileStmt ()) + +l3t5 = mkL3 (aspExtDeclarations ()) (aspProcDecl ()) (aspParamL_Cons ()) (aspParamL_Nil ()) (aspParam ()) + (aspProcCStmt ()) (aspExpressionL_Cons ()) (aspExpressionL_Nil ()) + (L1.aspEmptyStmt ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ()) diff --git a/src/Language/Oberon0/L3/T1.hs b/src/Language/Oberon0/L3/T1.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L3/T1.hs @@ -0,0 +1,14 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.MainT1 +import Language.Oberon0.L3.Gram +import Language.Oberon0.L3.SemT1 + + +import Language.Grammars.Murder +import Language.Grammars.AspectAG + + +c_l3t1 = closeGram (l1 l1t1 +>> l2 l2t1 +>> l3 l3t1) + +main = mainT1 (# spp) emptyRule "l3t1" l3Kws c_l3t1 diff --git a/src/Language/Oberon0/L3/T2.hs b/src/Language/Oberon0/L3/T2.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L3/T2.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.L3.Gram +import Language.Oberon0.L3.SemT2 +import Language.Oberon0.MainT2 + +import Language.Grammars.Murder +import Language.Grammars.AspectAG + + +c_l3t2 = closeGram (l1 l1t2 +>> l2 l2t2 +>> l3 l3t2) + + +main = mainT2 (# spp) (# serr) (ienv .=. ienvIni () .*. emptyRecord) "l3t2" l3Kws c_l3t2 + diff --git a/src/Language/Oberon0/L3/T3.hs b/src/Language/Oberon0/L3/T3.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L3/T3.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.L3.Gram +import Language.Oberon0.L3.SemT3 +import Language.Oberon0.MainT2 + +import Language.Grammars.Murder +import Language.Grammars.AspectAG + + +c_l3t3 = closeGram (l1 l1t3 +>> l2 l2t3 +>> l3 l3t3) + + +main = mainT2 (# spp) (# serr) (ienv .=. ienvIni () .*. emptyRecord) "l3t3" l3Kws c_l3t3 + diff --git a/src/Language/Oberon0/L3/T5.hs b/src/Language/Oberon0/L3/T5.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L3/T5.hs @@ -0,0 +1,16 @@ +{-# OPTIONS -fcontext-stack=3000 #-} + +import Language.Oberon0.L3.Gram +import Language.Oberon0.L3.SemT5 +import Language.Oberon0.MainT5 + +import Language.Grammars.Murder +import Language.Grammars.AspectAG + + +c_l3t5 = closeGram (l1 l1t5 +>> l2 l2t5 +>> l3 l3t5) + + +main = mainT5 (# spp) (# serr) (# scgen) (ienv .=. ienvIni () .*. emptyRecord) "l3t5" l3Kws c_l3t5 + + diff --git a/src/Language/Oberon0/L4/Decl.hs b/src/Language/Oberon0/L4/Decl.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L4/Decl.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-} + +module Language.Oberon0.L4.Decl (module Language.Oberon0.L3.Decl, module Language.Oberon0.L4.Decl) where + +import Language.Oberon0.L3.Decl + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive + + +---- L4 Grammar + +-- Procedure + +data EXT_Type = ArrayType { exp_ArrayType :: Expression, typ_ArrayType :: Type } + | RecordType { fields_RecordType :: FieldL } + +type FieldL = [Field] + + +data Field = Field { idl_Field :: IdentL, typ_Field :: Type } + | EmptyField + + + +$(extendAG ''EXT_Type [''Expression,''IdentL, ''Type]) + + +data EXT2_Expression = SelExp { id_SelExp :: String, sel_SelExp :: SelectL } + +type SelectL = [Select] + + +data Select = SelField { id_SelField :: String } + | SelArray { exp_SelArray :: Expression } + + +$(extendAG ''EXT2_Expression [''Expression]) + + +data EXT3_Statement + = AssigSelStmt { id_AssigSelStmt :: String, sel_AssigSelStmt :: SelectL, exp_AssigSelStmt :: Expression } + +$(extendAG ''EXT3_Statement [''SelectL,''Expression]) + +$(deriveLang "L4" [''EXT_Type, ''FieldL, ''Field, ''EXT2_Expression, ''SelectL, ''Select, ''EXT3_Statement]) + diff --git a/src/Language/Oberon0/L4/Gram.hs b/src/Language/Oberon0/L4/Gram.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L4/Gram.hs @@ -0,0 +1,49 @@ +{-# OPTIONS -fcontext-stack=100 #-} + +{-# LANGUAGE Arrows, DoRec #-} + +module Language.Oberon0.L4.Gram (module Language.Oberon0.L4.Gram, module Language.Oberon0.L3.Gram) where + +import Language.Oberon0.L3.Gram +import Language.Oberon0.L4.Decl + +import Control.Arrow +import Control.Applicative +import Data.Set (union,fromList) + +import Language.Grammars.Murder +import Language.Grammars.Grammar + +import Language.Grammars.AspectAG + + +l4 sf = proc imported -> do + let statement = getNT cs_Statement imported + let exp = getNT cs_Expression imported + let factor = getNT cs_Factor imported + let ident = getNT cs_Ident imported + let idl = getNT cs_IdentL imported + let typ = getNT cs_Type imported + + + rec addProds -< (typ, iI (pArrayType sf) "ARRAY" exp "OF" typ Ii + <|> iI (pRecordType sf) "RECORD" fieldl "END" Ii) + + fieldl <- addNT -< iI (pFieldL_Cons sf) field (pFoldr (pFieldL_Cons sf, pFieldL_Nil sf) (iI ";" field Ii)) Ii + + field <- addNT -< iI (pField sf) idl ":" typ Ii <|> iI (pEmptyField sf) Ii + + + addProds -< (factor, iI (pSelExp sf) ident selector Ii) + + + selector <- addNT -< iI (pSelectL_Cons sf) sel (pFoldr (pSelectL_Cons sf, pSelectL_Nil sf) (iI sel Ii)) Ii + + sel <- addNT -< iI (pSelField sf) "." ident Ii <|> iI (pSelArray sf) "[" exp "]" Ii + + addProds -< (statement, iI (pAssigSelStmt sf) ident selector ":=" exp Ii) + + exportNTs -< imported + +l4Kws = union l3Kws $ fromList ["ARRAY","RECORD"] + diff --git a/src/Language/Oberon0/L4/SemT1.hs b/src/Language/Oberon0/L4/SemT1.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L4/SemT1.hs @@ -0,0 +1,108 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-} + +module Language.Oberon0.L4.SemT1 (module Language.Oberon0.L4.SemT1, module Language.Oberon0.L3.SemT1) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..), Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import UU.Pretty + +import Language.Oberon0.L4.Decl + + +import qualified Language.Oberon0.L3.SemT1 as L3 +import Language.Oberon0.L3.SemT1 (l1t1,l2t1,l3t1,spp,sppl,sidl) + + +---- T1(L3) Pretty-Printing + + +sppNT = nt_Field .*. nt_Select .*. L3.sppNT + + + +sppArrayType = syn spp $ do exp <- at ch_exp_ArrayType + typ <- at ch_typ_ArrayType + + return $ "ARRAY" >#< exp # spp >#< "OF" >#< typ # spp + +sppRecordType = syn spp $ do fields <- at ch_fields_RecordType + return $ pp_block " RECORD " " END " ";" (fields # sppl) + +sppField = syn spp $ do idl <- at ch_idl_Field + typ <- at ch_typ_Field + return $ case (map pp (idl # sidl)) of + [] -> empty + ppidl -> pp_block "" "" ", " ppidl >#< ":" >#< typ # spp + +sppEmptyField = syn spp $ do return empty + +sppSelExp = syn spp $ do id <- at ch_id_SelExp + sel <- at ch_sel_SelExp + return $ value id >|< pp_block "" "" "" (sel # sppl) + +sppSelField = syn spp $ do id <- at ch_id_SelField + return $ "." >|< value id + +sppSelArray = syn spp $ do exp <- at ch_exp_SelArray + return $ "[" >|< exp # spp >|< "]" + +-- sppl + +spplNT = nt_FieldL .*. nt_SelectL .*. L3.spplNT + + +spplFieldL_Cons = syn sppl $ do hd <- at ch_hd_FieldL_Cons + tl <- at ch_tl_FieldL_Cons + return $ (hd # spp) : (tl # sppl) + +spplFieldL_Nil = syn sppl $ do return $ ([] :: [PP_Doc]) + + +spplSelectL_Cons = syn sppl $ do h <- at ch_hd_SelectL_Cons + t <- at ch_tl_SelectL_Cons + return $ (h # spp) : (t # sppl) +spplSelectL_Nil = syn sppl $ do return $ ([] :: [PP_Doc]) + + +spplAssigSelStmt = syn sppl $ do id <- at ch_id_AssigSelStmt + sel <- at ch_sel_AssigSelStmt + exp <- at ch_exp_AssigSelStmt + return $ [ value id >|< pp_block "" "" "" (sel # sppl) >#< ":=" >#< exp # spp ] + +---- Aspects + +aspArrayType = sppArrayType + +aspRecordType = sppRecordType + +aspFieldL_Cons = spplFieldL_Cons +aspFieldL_Nil = spplFieldL_Nil + +aspField = sppField +aspEmptyField = sppEmptyField + +aspSelExp = sppSelExp + +aspSelectL_Cons = spplSelectL_Cons +aspSelectL_Nil = spplSelectL_Nil + +aspSelField = sppSelField +aspSelArray = sppSelArray + + +aspAssigSelStmt = spplAssigSelStmt + +---- Semantic Functions + + + +l4t1 = mkL4 aspArrayType aspAssigSelStmt aspEmptyField aspField aspFieldL_Cons aspFieldL_Nil + aspRecordType aspSelArray aspSelExp aspSelField aspSelectL_Cons aspSelectL_Nil + diff --git a/src/Language/Oberon0/L4/SemT2.hs b/src/Language/Oberon0/L4/SemT2.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L4/SemT2.hs @@ -0,0 +1,107 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction, ScopedTypeVariables #-} + +module Language.Oberon0.L4.SemT2 (module Language.Oberon0.L4.SemT2, module Language.Oberon0.L3.SemT2) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..),Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import qualified Data.Map as Map + + +import Language.Oberon0.L4.Decl + +import qualified Language.Oberon0.L4.SemT1 as T1 + + +import qualified Language.Oberon0.L3.SemT2 as L3 +import Language.Oberon0.L3.SemT2 (l1t2,l2t2,l3t2,spp,sppl,sidl,senv,ienv,serr,spos,SymbolInfo(..),NameDef(..),NInfo,checkName) + + +---- T2 (L4) Name binding + + +-- spos + +sposRecordType = syn spos $ do return $ Pos 0 0 --TODO? + + +sposArrayType = syn spos $ do return $ Pos 0 0 --TODO? + + + +-- senv + +senvNT = nt_Field .*. nt_FieldL .*. L3.senvNT + +senvRule (_ :: a) = use senv senvNT Map.union (Map.empty :: Map.Map String (NInfo a)) + + + +-- ienv + +ienvNT = nt_Select .*. nt_SelectL .*. nt_Field .*. nt_FieldL .*. L3.ienvNT + +ienvRule _ = copy ienv ienvNT + +ienvIni = L3.ienvIni + +ienvRecordType r = inh ienv ienvNT $ do lhs <- at lhs + fields <- at ch_fields_RecordType + + return $ ch_fields_RecordType .=. Map.union (fields # senv) (lhs # ienv) .*. + emptyRecord + +-- serr + +serrNT = nt_Select .*. nt_SelectL .*. nt_Field .*. nt_FieldL .*. L3.serrNT + + +serrRule = use serr serrNT (++) ([] :: [String]) + +serrSelExp = syn serr $ do id <- at ch_id_SelExp + lhs <- at lhs + return $ checkName id (lhs # ienv) ["Var"] "an expression" + + +serrAssigSelStmt = syn serr $ do id <- at ch_id_AssigSelStmt + exp <- at ch_exp_AssigSelStmt + lhs <- at lhs + return $ checkName id (lhs # ienv) ["Var"] "an assignment" ++ exp # serr + + + + +---- Aspects + +aspArrayType r = sposArrayType `ext` (ienvRule r) `ext` serrRule `ext` T1.aspArrayType + +aspRecordType r = sposRecordType `ext` (ienvRecordType r) `ext` serrRule `ext` T1.aspRecordType + +aspFieldL_Cons r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspFieldL_Cons +aspFieldL_Nil r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspFieldL_Nil + +aspField r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspField +aspEmptyField r = (senvRule r) `ext` (ienvRule r) `ext` serrRule `ext` T1.aspEmptyField + +aspSelExp r = (ienvRule r) `ext` serrSelExp `ext` T1.aspSelExp + +aspSelectL_Cons r = (ienvRule r) `ext` serrRule `ext` T1.aspSelectL_Cons +aspSelectL_Nil r = (ienvRule r) `ext` serrRule `ext` T1.aspSelectL_Nil + +aspSelField r = (ienvRule r) `ext` serrRule `ext` T1.aspSelField +aspSelArray r = (ienvRule r) `ext` serrRule `ext` T1.aspSelArray + + +aspAssigSelStmt r = (ienvRule r) `ext` serrAssigSelStmt `ext` T1.aspAssigSelStmt + +---- Semantic Functions + +l4t2 = mkL4 (aspArrayType ()) (aspAssigSelStmt ()) (aspEmptyField ()) (aspField ()) (aspFieldL_Cons ()) (aspFieldL_Nil ()) + (aspRecordType ()) (aspSelArray ()) (aspSelExp ()) (aspSelField ()) (aspSelectL_Cons ()) (aspSelectL_Nil ()) + diff --git a/src/Language/Oberon0/L4/SemT3.hs b/src/Language/Oberon0/L4/SemT3.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L4/SemT3.hs @@ -0,0 +1,301 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction, TemplateHaskell, DeriveDataTypeable #-} + +module Language.Oberon0.L4.SemT3 (module Language.Oberon0.L4.SemT3, module Language.Oberon0.L3.SemT3) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..),Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import qualified Data.Map as Map +import Data.List (intercalate) +import Data.Dynamic + +import Language.Oberon0.L4.Decl + +import qualified Language.Oberon0.L4.SemT2 as T2 + +import qualified Language.Oberon0.L1.SemT3 as L1 + +import qualified Language.Oberon0.L3.SemT3 as L3 +import Language.Oberon0.L3.SemT3 (mkL1'',l2t3,spp,sidl,sval,senv,ienv,serr,spos,sty,sterr,sknd,spl,ParamInfo(..),check,SymbolInfo(..),NameDef(..),TInfo(..) + ,baseType,intType,boolType,unkType,findType) + + +---- T3 (L4) Type-checking + + +data ArrType = ArrType (Maybe Int) TInfo + deriving Typeable + +instance Show ArrType where + show (ArrType _ ty) = "ARRAY OF " ++ show ty + +data RecType = RecType [ FInfo ] + deriving Typeable + +data FInfo = FInfo String TInfo + deriving Typeable + +instance Show FInfo where + show (FInfo f t) = f ++ ": " ++ show t +instance Show RecType where + show (RecType fs) = "RECORD " ++ intercalate "; " (map show fs) ++ " END" + + +arrayType l ty = let t = (ArrType l ty) + in TInfo (toDyn t) (show t) (const False) + +recordType fts = let t = (RecType fts) + in TInfo (toDyn t) (show t) (const False) + +-- sknd + +skndSelExp = syn sknd $ do return $ VarP + +-- spos + +sposSelExp = syn spos $ do i <- at ch_id_SelExp + return $ pos i + + +-- ity + +$(attLabels ["ity"]) + +ityNT = nt_Select .*. nt_SelectL .*. hNil + +ityRule = copy ity ityNT + + +ityAssigSelStmt = inh ity ityNT $ + do lhs <- at lhs + id <- at ch_id_AssigSelStmt + return $ ch_sel_AssigSelStmt .=. findType (value id) (lhs # ienv) .*. + emptyRecord + + +itySelExp = inh ity ityNT $ do lhs <- at lhs + id <- at ch_id_SelExp + return $ ch_sel_SelExp .=. findType (value id) (lhs # ienv) .*. + emptyRecord + +itySelectL_Cons = inh ity ityNT $ do lhs <- at lhs + h <- at ch_hd_SelectL_Cons + return $ ch_hd_SelectL_Cons .=. lhs # ity .*. + ch_tl_SelectL_Cons .=. h # sty .*. + emptyRecord + + +-- sty + +styNT = nt_Select .*. nt_SelectL .*. L3.styNT + +styArrayType = syn sty $ do exp <- at ch_exp_ArrayType + typ <- at ch_typ_ArrayType + return $ arrayType (exp # sval) (typ # sty) + +styRecordType = syn sty $ do fields <- at ch_fields_RecordType + let fs = Map.toList (fields # senv) + return $ recordType (map (\(f, SI _ (SI t _)) -> FInfo f t) fs) + + +stySelExp = syn sty $ do sel <- at ch_sel_SelExp + return $ sel # sty + + +fieldType _ [] = Nothing +fieldType n ((FInfo f ft):fs) | n == f = Just ft + | otherwise = fieldType n fs + +stySelField = syn sty $ do lhs <- at lhs + ids <- at ch_id_SelField + + return $ case (fromDynamic . trep . baseType) (lhs # ity) of + Just (RecType fs) -> maybe unkType id (fieldType (value ids) fs) + _ -> unkType + + +stySelArray = syn sty $ do lhs <- at lhs + + return $ case (fromDynamic . trep . baseType) (lhs # ity) of + Just (ArrType _ t) -> t + _ -> unkType + + +stySelectL_Cons = syn sty $ do t <- at ch_tl_SelectL_Cons + return $ t # sty +stySelectL_Nil = syn sty $ do lhs <- at lhs + return $ lhs # ity + +-- sval + +svalNT = L3.svalNT + +svalSelExp = syn sval $ do return $ Nothing + +-- senv + +senvNT = T2.senvNT + + +senvField' r = synupdM senv $ do typ <- at ch_typ_Field + return $ Map.map (\(SI nd _) -> (SI nd (SI (typ # sty) r))) + +-- ienv + +ienvNT = T2.ienvNT + +ienvIni = L3.ienvIni + +-- serr + +sterrNT = nt_Select .*. nt_SelectL .*. nt_Field .*. nt_FieldL .*. L3.sterrNT + + +sterrRule = use sterr sterrNT (++) ([] :: [String]) + +checkSize pos (Just s) | s < 0 = [ show pos ++ ": Array size is negative" ] + | otherwise = [] +checkSize _ _ = [] + +sterrArrayType = syn sterr $ do exp <- at ch_exp_ArrayType + typ <- at ch_typ_ArrayType + return $ check (exp # spos) intType (exp # sty) ++ checkSize (exp # spos) (exp # sval) ++ exp # sterr ++ typ # sterr + +sterrSelField = syn sterr $ do lhs <- at lhs + id <- at ch_id_SelField + + return $ if teq (lhs # ity) unkType + then [] + else case (fromDynamic . trep . baseType) (lhs # ity) of + Just (RecType fs) -> maybe [ show (pos id) ++ ": The record does not contain a field with name " ++ value id ] + (const []) (fieldType (value id) fs) + _ -> [ (show . L1.moveLeft) (pos id) ++ ": The accessed variable is not a record." ] + +checkIndex pos (Just i) (Just l) | i < 0 || i >= l = [ show pos ++ ": Index out of range" ] + | otherwise = [ ] + +checkIndex _ _ _ = [] + + +sterrSelArray = syn sterr $ do lhs <- at lhs + exp <- at ch_exp_SelArray + let err = if teq (lhs # ity) unkType + then [] + else case (fromDynamic . trep . baseType) (lhs # ity) of + Just (ArrType l t) -> checkIndex (exp # spos) (exp # sval) l + _ -> [ (show . L1.moveLeft) (exp # spos) ++ ": The accessed variable is not an array." ] + + return $ err ++ check (exp # spos) intType (exp # sty) + +checkAssig pos ty = let errR = case (fromDynamic . trep . baseType) ty of + Just (RecType _) -> [ show pos ++ ": Can not assign to a record." ] + _ -> [ ] + errA = case (fromDynamic . trep . baseType) ty of + Just (ArrType _ _) -> [ show pos ++ ": Can not assign to an array." ] + _ -> [ ] + in errR ++ errA + +sterrAssigSelStmt = syn sterr $ do id <- at ch_id_AssigSelStmt + sel <- at ch_sel_AssigSelStmt + exp <- at ch_exp_AssigSelStmt + let lerr = checkAssig (pos id) (sel # sty) ++ (sel # sterr) + return $ if lerr == [] + then check (exp # spos) (sel # sty) (exp # sty) ++ exp # sterr + else lerr + + +sterrAssigStmt' = synupdM sterr $ do lhs <- at lhs + id <- at ch_id_AssigStmt + let lerr = checkAssig (pos id) (findType (value id) (lhs # ienv)) + return $ \err -> if lerr == [] then err else lerr + + +checkSt _ ty VarP = [] +checkSt pos ty _ = let errR = case (fromDynamic . trep . baseType) ty of + Just (RecType _) -> [ show pos ++ ": Ilegal parameter, a record parameter has to be a variable." ] + _ -> [ ] + errA = case (fromDynamic . trep . baseType) ty of + Just (ArrType _ _) -> [ show pos ++ ": Ilegal parameter, an array parameter has to be a variable." ] + _ -> [ ] + in errR ++ errA + +sterrParam' = synupdM sterr $ do knd <- at ch_kind_Param + idl <- at ch_idl_Param + typ <- at ch_typ_Param + return $ \err -> err ++ checkSt (idl # spos) (typ # sty) knd + + +---- Aspects +pTInfo :: a -> SymbolInfo TInfo a +pTInfo _ = undefined + +aspArrayType r = styArrayType `ext` sterrArrayType `ext` (T2.aspArrayType (pTInfo r)) + +aspRecordType r = styRecordType `ext` sterrRule `ext` (T2.aspRecordType (pTInfo r)) + +aspFieldL_Cons r = sterrRule `ext` (T2.aspFieldL_Cons (pTInfo r)) +aspFieldL_Nil r = sterrRule `ext` (T2.aspFieldL_Nil (pTInfo r)) + +aspField r = (senvField' r) `ext` sterrRule `ext` (T2.aspField (pTInfo r)) +aspEmptyField r = sterrRule `ext` (T2.aspEmptyField (pTInfo r)) + +aspSelExp r = itySelExp `ext` sposSelExp `ext` stySelExp `ext`svalSelExp `ext` sterrRule `ext` (T2.aspSelExp (pTInfo r)) + +aspSelectL_Cons r = itySelectL_Cons `ext` stySelectL_Cons `ext` sterrRule `ext` (T2.aspSelectL_Cons (pTInfo r)) +aspSelectL_Nil r = ityRule `ext` stySelectL_Nil `ext` sterrRule `ext` (T2.aspSelectL_Nil (pTInfo r)) + +aspSelField r = ityRule `ext` stySelField `ext` sterrSelField `ext` (T2.aspSelField (pTInfo r)) +aspSelArray r = ityRule `ext` stySelArray `ext` sterrSelArray `ext` (T2.aspSelArray (pTInfo r)) + + +aspAssigSelStmt r = ityAssigSelStmt `ext` sterrAssigSelStmt `ext` (T2.aspAssigSelStmt (pTInfo r)) + +---- Semantic Functions + +mkL1''' aspAssigStmt aspBoolBOpExp aspBoolExp aspBoolUOpExp aspCondStmt aspCondStmtL_Cons + aspCondStmtL_Nil aspCstDecl aspDeclL_Cons aspDeclL_Nil aspDecls aspEmptyStmt + aspIdExp aspIdentL_Cons aspIdentL_Nil aspIfStmt aspIntBOpExp aspIntCmpExp aspIntExp + aspIntUOpExp aspMaybeElseStmt_Just aspMaybeElseStmt_Nothing aspModule aspParExp + aspSeqStmt aspTypDecl aspType aspVarDecl aspWhileStmt + = mkL1'' (sterrAssigStmt' `ext` aspAssigStmt) aspBoolBOpExp aspBoolExp + aspBoolUOpExp aspCondStmt aspCondStmtL_Cons + aspCondStmtL_Nil aspCstDecl aspDeclL_Cons aspDeclL_Nil aspDecls aspEmptyStmt + aspIdExp aspIdentL_Cons aspIdentL_Nil aspIfStmt aspIntBOpExp + aspIntCmpExp aspIntExp + aspIntUOpExp aspMaybeElseStmt_Just aspMaybeElseStmt_Nothing aspModule + aspParExp aspSeqStmt aspTypDecl aspType aspVarDecl aspWhileStmt + + +l1t3 = mkL1''' (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspBoolUOpExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ()) + (L1.aspCondStmtL_Nil ()) (L1.aspCstDecl ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ()) (L1.aspDecls ()) (L1.aspEmptyStmt ()) + (L1.aspIdExp ()) (L1.aspIdentL_Cons ()) (L1.aspIdentL_Nil ()) (L1.aspIfStmt ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ()) + (L1.aspIntUOpExp ()) (L1.aspMaybeElseStmt_Just ()) (L1.aspMaybeElseStmt_Nothing ()) (L1.aspModule ()) (L1.aspParExp ()) + (L1.aspSeqStmt ()) (L1.aspTypDecl ()) (L1.aspType ()) (L1.aspVarDecl ()) (L1.aspWhileStmt ()) + +mkL3' _aspExtDeclarations _aspProcDecl _aspParamL_Cons _aspParamL_Nil _aspParam + _aspProcCStmt _aspExpressionL_Cons _aspExpressionL_Nil + _aspEmptyStmt _aspDeclL_Cons _aspDeclL_Nil + = mkL3 _aspExtDeclarations _aspProcDecl _aspParamL_Cons _aspParamL_Nil (sterrParam' `ext` _aspParam) + _aspProcCStmt _aspExpressionL_Cons _aspExpressionL_Nil + _aspEmptyStmt _aspDeclL_Cons _aspDeclL_Nil + +l3t3 = mkL3' (L3.aspExtDeclarations ()) (L3.aspProcDecl ()) (L3.aspParamL_Cons ()) (L3.aspParamL_Nil ()) (L3.aspParam ()) + (L3.aspProcCStmt ()) (L3.aspExpressionL_Cons ()) (L3.aspExpressionL_Nil ()) + (L1.aspEmptyStmt ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ()) + +mkL4' _aspArrayType _aspAssigSelStmt _aspEmptyField _aspField _aspFieldL_Cons _aspFieldL_Nil + _aspRecordType _aspSelArray _aspSelExp _aspSelField _aspSelectL_Cons _aspSelectL_Nil + = mkL4 _aspArrayType _aspAssigSelStmt _aspEmptyField _aspField _aspFieldL_Cons _aspFieldL_Nil + _aspRecordType _aspSelArray (skndSelExp `ext` _aspSelExp) _aspSelField _aspSelectL_Cons _aspSelectL_Nil + + + +l4t3 = mkL4' (aspArrayType ()) (aspAssigSelStmt ()) (aspEmptyField ()) (aspField ()) (aspFieldL_Cons ()) (aspFieldL_Nil ()) + (aspRecordType ()) (aspSelArray ()) (aspSelExp ()) (aspSelField ()) (aspSelectL_Cons ()) (aspSelectL_Nil ()) + diff --git a/src/Language/Oberon0/L4/SemT5.hs b/src/Language/Oberon0/L4/SemT5.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L4/SemT5.hs @@ -0,0 +1,165 @@ +{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction, TemplateHaskell #-} + +module Language.Oberon0.L4.SemT5 (module Language.Oberon0.L4.SemT5, module Language.Oberon0.L3.SemT5) where + +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.Derive +import Language.Grammars.Grammar (DTerm(..),Pos(..)) + +import Data.HList.Label4 +import Data.HList.TypeEqGeneric1 +import Data.HList.TypeCastGeneric1 + +import Language.C + + +import Language.Oberon0.L4.Decl + +import qualified Language.Oberon0.L4.SemT3 as T3 + +import qualified Language.Oberon0.L1.SemT5 as L1 + +import qualified Language.Oberon0.L3.SemT5 as L3 +import Language.Oberon0.L3.SemT5 (l2t5 + ,spp,sidl,senv,ienv,serr,spos,sty,sterr,SymbolInfo(..),NameDef(..),TInfo(..),baseType,intType,boolType,unkType,findType + ,scgen,scdec,scdecl,scty,scexp,scstmt,ipre,mapIdent,updMap,compStmt) + + +---- T5 (L4) Code Generation + +-- ipre + +ipreNT = nt_Select .*. nt_SelectL .*. nt_Field .*. nt_FieldL .*. L3.ipreNT + +ipreRule = copy ipre ipreNT + + +-- senv + +senvNT = T3.senvNT + +-- ienv + +ienvNT = T3.ienvNT + +ienvIni = L3.ienvIni + + +ienvRule _ = copy ienv ienvNT + +-- scsel + +$(attLabels ["scsel"]) + +scselNT = nt_Select .*. nt_SelectL .*. hNil + +scselSelField = syn scsel $ do ids <- at ch_id_SelField + return $ \exp -> CMember exp (internalIdent $ value ids) False undefNode + + +scselSelArray = syn scsel $ do ind <- at ch_exp_SelArray + return $ \exp -> CIndex exp (ind # scexp) undefNode + + +scselSelectL_Cons = syn scsel $ do h <- at ch_hd_SelectL_Cons + t <- at ch_tl_SelectL_Cons + return $ (t # scsel) . (h # scsel) +scselSelectL_Nil = syn scsel $ do return $ id + +-- scexp + +scexpNT = L3.scexpNT + +scexpSelExp = syn scexp $ do lhs <- at lhs + id <- at ch_id_SelExp + sel <- at ch_sel_SelExp + return $ (sel # scsel) (CVar (mapIdent (value id) (lhs # ienv)) undefNode) + + +-- scstmt + +scstmtNT = L3.scstmtNT + +scstmtAssigSelStmt = syn scstmt $ do lhs <- at lhs + id <- at ch_id_AssigSelStmt + sel <- at ch_sel_AssigSelStmt + exp <- at ch_exp_AssigSelStmt + let rhs = (sel # scsel) (CVar (mapIdent (value id) (lhs # ienv)) undefNode) + + return $ CExpr (Just $ CAssign CAssignOp rhs (exp # scexp) undefNode) undefNode + +-- scdec + +scdecNT = nt_Field .*. nt_FieldL .*. L3.scdecNT + +scdecRule = use scdec scdecNT (++) ([] :: [CDeclaration NodeInfo]) + + +scdecField = syn scdec $ do idl <- at ch_idl_Field + typ <- at ch_typ_Field + let (tys,tyd) = typ # scty + return $ map (\name -> ( CDecl [ tys ] + [(Just (CDeclr (Just $ internalIdent name) tyd Nothing [] undefNode),Nothing,Nothing)] + undefNode)) + (idl # sidl) + + +-- scty + +sctyArrayType = syn scty $ do exp <- at ch_exp_ArrayType + typ <- at ch_typ_ArrayType + let (tys,tyd) = typ # scty + return $ (tys, tyd ++ [CArrDeclr [] (CArrSize False (exp # scexp)) undefNode] ) + +sctyRecordType = syn scty $ do fields <- at ch_fields_RecordType + return $ (CTypeSpec (CSUType (CStruct CStructTag Nothing (Just (fields # scdec)) [] undefNode) undefNode) , []) + + + + +---- Aspects +pMap :: a -> SymbolInfo String a +pMap _ = undefined + +aspArrayType r = ipreRule `ext` (ienvRule r) `ext` sctyArrayType `ext` (T3.aspArrayType (pMap r)) + +aspRecordType r = ipreRule `ext` (ienvRule r) `ext` sctyRecordType `ext` (T3.aspRecordType (pMap r)) + +aspFieldL_Cons r = ipreRule `ext` (ienvRule r) `ext` scdecRule `ext` (T3.aspFieldL_Cons (pMap r)) +aspFieldL_Nil r = ipreRule `ext` (ienvRule r) `ext` scdecRule `ext` (T3.aspFieldL_Nil (pMap r)) + +aspField r = ipreRule `ext` (ienvRule r) `ext` scdecField `ext` (T3.aspField (pMap r)) +aspEmptyField r = ipreRule `ext` (ienvRule r) `ext` scdecRule `ext` (T3.aspEmptyField (pMap r)) + +aspSelExp r = ipreRule `ext` (ienvRule r) `ext` scexpSelExp `ext` (T3.aspSelExp (pMap r)) + +aspSelectL_Cons r = ipreRule `ext` (ienvRule r) `ext` scselSelectL_Cons `ext` (T3.aspSelectL_Cons (pMap r)) +aspSelectL_Nil r = ipreRule `ext` (ienvRule r) `ext` scselSelectL_Nil `ext` (T3.aspSelectL_Nil (pMap r)) + +aspSelField r = ipreRule `ext` (ienvRule r) `ext` scselSelField `ext` (T3.aspSelField (pMap r)) +aspSelArray r = ipreRule `ext` (ienvRule r) `ext` scselSelArray `ext` (T3.aspSelArray (pMap r)) + + +aspAssigSelStmt r = ipreRule `ext` (ienvRule r) `ext` scstmtAssigSelStmt `ext` (T3.aspAssigSelStmt (pMap r)) + + +---- Semantic Functions +mkL1''' = T3.mkL1''' +mkL3' = T3.mkL3' + +l1t5 = mkL1''' (L1.aspAssigStmt ()) (L1.aspBoolBOpExp ()) (L1.aspBoolExp ()) (L1.aspBoolUOpExp ()) (L1.aspCondStmt ()) (L1.aspCondStmtL_Cons ()) + (L1.aspCondStmtL_Nil ()) (L1.aspCstDecl ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ()) (L1.aspDecls ()) (L1.aspEmptyStmt ()) + (L1.aspIdExp ()) (L1.aspIdentL_Cons ()) (L1.aspIdentL_Nil ()) (L1.aspIfStmt ()) (L1.aspIntBOpExp ()) (L1.aspIntCmpExp ()) (L1.aspIntExp ()) + (L1.aspIntUOpExp ()) (L1.aspMaybeElseStmt_Just ()) (L1.aspMaybeElseStmt_Nothing ()) (L1.aspModule ()) (L1.aspParExp ()) + (L1.aspSeqStmt ()) (L1.aspTypDecl ()) (L1.aspType ()) (L1.aspVarDecl ()) (L1.aspWhileStmt ()) + +l3t5 = mkL3' (L3.aspExtDeclarations ()) (L3.aspProcDecl ()) (L3.aspParamL_Cons ()) (L3.aspParamL_Nil ()) (L3.aspParam ()) + (L3.aspProcCStmt ()) (L3.aspExpressionL_Cons ()) (L3.aspExpressionL_Nil ()) + (L1.aspEmptyStmt ()) (L1.aspDeclL_Cons ()) (L1.aspDeclL_Nil ()) + +mkL4' = T3.mkL4' + +l4t5 = mkL4' (aspArrayType ()) (aspAssigSelStmt ()) (aspEmptyField ()) (aspField ()) (aspFieldL_Cons ()) (aspFieldL_Nil ()) + (aspRecordType ()) (aspSelArray ()) (aspSelExp ()) (aspSelField ()) (aspSelectL_Cons ()) (aspSelectL_Nil ()) + diff --git a/src/Language/Oberon0/L4/T1.hs b/src/Language/Oberon0/L4/T1.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L4/T1.hs @@ -0,0 +1,14 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.MainT1 +import Language.Oberon0.L4.Gram +import Language.Oberon0.L4.SemT1 + + +import Language.Grammars.Murder +import Language.Grammars.AspectAG + + +c_l4t1 = closeGram (l1 l1t1 +>> l2 l2t1 +>> l3 l3t1 +>> l4 l4t1) + +main = mainT1 (# spp) emptyRule "l4t1" l4Kws c_l4t1 diff --git a/src/Language/Oberon0/L4/T2.hs b/src/Language/Oberon0/L4/T2.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L4/T2.hs @@ -0,0 +1,14 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.MainT2 +import Language.Oberon0.L4.Gram +import Language.Oberon0.L4.SemT2 + + +import Language.Grammars.Murder +import Language.Grammars.AspectAG + + +c_l4t2 = closeGram (l1 l1t2 +>> l2 l2t2 +>> l3 l3t2 +>> l4 l4t2) + +main = mainT2 (# spp) (# serr) (ienv .=. ienvIni () .*. emptyRecord) "l4t2" l4Kws c_l4t2 diff --git a/src/Language/Oberon0/L4/T3.hs b/src/Language/Oberon0/L4/T3.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L4/T3.hs @@ -0,0 +1,14 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.MainT2 +import Language.Oberon0.L4.Gram +import Language.Oberon0.L4.SemT3 + + +import Language.Grammars.Murder +import Language.Grammars.AspectAG + + +c_l4t3 = closeGram (l1 l1t3 +>> l2 l2t3 +>> l3 l3t3 +>> l4 l4t3) + +main = mainT2 (# spp) (# serr) (ienv .=. ienvIni () .*. emptyRecord) "l4t3" l4Kws c_l4t3 diff --git a/src/Language/Oberon0/L4/T5.hs b/src/Language/Oberon0/L4/T5.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/L4/T5.hs @@ -0,0 +1,16 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +import Language.Oberon0.L4.Gram +import Language.Oberon0.L4.SemT5 +import Language.Oberon0.MainT5 + +import Language.Grammars.Murder +import Language.Grammars.AspectAG + + +c_l4t5 = closeGram (l1 l1t5 +>> l2 l2t5 +>> l3 l3t5 +>> l4 l4t5) + + +main = mainT5 (# spp) (# serr) (# scgen) (ienv .=. ienvIni () .*. emptyRecord) "l4t5" l4Kws c_l4t5 + + diff --git a/src/Language/Oberon0/MainT1.hs b/src/Language/Oberon0/MainT1.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/MainT1.hs @@ -0,0 +1,64 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +module Language.Oberon0.MainT1 where + +import System.Environment( getArgs ) +import System.Console.GetOpt + +import Language.Grammars.Murder +import Language.Grammars.Murder.UUParsing + + + +data Flag = MaxErr Int | PP (Maybe String) | Gen (Maybe String) + deriving (Show, Eq, Ord) + +options :: [OptDescr Flag] +options = + [ Option ['p'] ["pretty"] (OptArg PP "FILE") "pretty-print" + , Option ['e'] ["errors"] (ReqArg (MaxErr . read) "NUMBER") "maximum number of errors to list" + ] + + +maxerrors ((MaxErr e):_) le = if e < le then e else le +maxerrors (_:fs) le = maxerrors fs le +maxerrors [] le = le + +prettyprint ((PP mbfile):_ ) ppcode = case mbfile of + Just file -> writeFile file (show ppcode) + Nothing -> do putStrLn "Pretty-printed code:" + print ppcode +prettyprint (_:fs) ppcode = prettyprint fs ppcode +prettyprint [] _ = return () + + + +remComments ('(':'*':xs) level = ' ':' ':(remComments xs (level + 1)) +remComments ('*':')':xs) level | level > 0 = ' ':' ':(remComments xs (level - 1)) + | otherwise = '*':')':xs +remComments ('\n':xs) level = '\n':(remComments xs level) + +remComments (x:xs) level | level > 0 = ' ':(remComments xs level) + | otherwise = x:(remComments xs level) +remComments [] _ = [] + + +mainTemplate opts task ip prg kws gram = do + args <- getArgs + case getOpt Permute opts args of + (flags, prg:nonOpts, []) -> do tokens <- readFile prg + case (parse . compileKws kws) gram (remComments tokens 0) of + (Ok res) -> do let atts = res ip + task flags atts + + (Rep _ err) -> do let maxerr = maxerrors flags (length err) + putStrLn "Errors found while parsing:" + mapM_ (putStrLn . show) $ take maxerr err + putStrLn $ "--- Listed " ++ show maxerr ++ " of " ++ show (length err) + + (_, _, errs) -> ioError (userError (concat errs ++ usageInfo ("Usage: " ++ prg ++ " [OPTIONS] file") opts)) + + + +mainT1 ppatt = mainTemplate options $ \flags atts -> prettyprint flags (ppatt atts) + diff --git a/src/Language/Oberon0/MainT2.hs b/src/Language/Oberon0/MainT2.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/MainT2.hs @@ -0,0 +1,20 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +module Language.Oberon0.MainT2 (module Language.Oberon0.MainT2, module Language.Oberon0.MainT1) where + +import Language.Oberon0.MainT1 + +printerrors flags errs = do let maxerr = maxerrors flags (length errs) + if maxerr == 0 + then do return False + else do putStrLn "Errors found while compiling:" + mapM_ putStrLn $ take maxerr errs + putStrLn $ "--- Listed " ++ show maxerr ++ " of " ++ show (length errs) + return True + + +mainT2 ppatt erratt = mainTemplate options $ \flags atts -> do + prettyprint flags (ppatt atts) + printerrors flags (erratt atts) + return () + diff --git a/src/Language/Oberon0/MainT5.hs b/src/Language/Oberon0/MainT5.hs new file mode 100644 --- /dev/null +++ b/src/Language/Oberon0/MainT5.hs @@ -0,0 +1,32 @@ +{-# OPTIONS -fcontext-stack=1000 #-} + +module Language.Oberon0.MainT5 (module Language.Oberon0.MainT5, module Language.Oberon0.MainT2) where + +import System.Console.GetOpt +import Control.Monad (when) +import Language.C + +import Language.Oberon0.MainT2 hiding (options) + +options :: [OptDescr Flag] +options = + [ Option ['p'] ["pretty"] (OptArg PP "FILE") "pretty-print" + , Option ['g'] ["gen"] (OptArg Gen "FILE") "generate C code" + , Option ['e'] ["errors"] (ReqArg (MaxErr . read) "NUMBER") "maximum number of errors to list" + ] + + +gencode ((Gen mbfile):_) cgen = let ccode = "#include \n" ++ show (pretty cgen) + in case mbfile of + Just file -> writeFile file ccode + Nothing -> do putStrLn "Generated code:" + putStrLn ccode +gencode (_:fs) cgen = gencode fs cgen +gencode [] _ = return () + + +mainT5 ppatt erratt cgenatt = mainTemplate options $ \flags atts -> do + prettyprint flags (ppatt atts) + errors <- printerrors flags (erratt atts) + when (not errors) $ gencode flags (cgenatt atts) +