packages feed

oberon0 (empty) → 0.0.1

raw patch · 58 files changed

+5233/−0 lines, 58 filesdep +AspectAGdep +HListdep +arraybuild-type:Customsetup-changed

Dependencies added: AspectAG, HList, array, base, containers, ghc-prim, language-c, mtl, murder, oberon0, template-haskell, transformers, uu-parsinglib, uulib

Files

+ LICENSE-LGPL view
@@ -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.++    <one line to give the library's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This library is free software; you can redistribute it and/or+    modify it under the terms of the GNU Lesser General Public+    License as published by the Free Software Foundation; either+    version 2.1 of the License, or (at your option) any later version.++    This library is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU+    Lesser General Public License for more details.++    You should have received a copy of the GNU Lesser General Public+    License along with this library; if not, write to the Free Software+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA++Also add information on how to contact you by electronic and paper mail.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the library, if+necessary.  Here is a sample; alter the names:++  Yoyodyne, Inc., hereby disclaims all copyright interest in the+  library `Frob' (a library for tweaking knobs) written by James Random Hacker.++  <signature of Ty Coon>, 1 April 1990+  Ty Coon, President of Vice++That's all there is to it!+
+ README view
@@ -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++
+ Setup.hs view
@@ -0,0 +1,3 @@++import Distribution.Simple+main = defaultMain
+ example/const.ob view
@@ -0,0 +1,3 @@+MODULE hola;+CONST X = (2); +END chau.
+ example/prog1.ob view
@@ -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.
+ example/prog1ok.ob view
@@ -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.
+ example/prog2.ob view
@@ -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.
+ example/prog2ok.ob view
@@ -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.
+ example/prog3.ob view
@@ -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.
+ example/prog3ok.ob view
@@ -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.
+ example/prog4.ob view
@@ -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.
+ example/prog4ok.c view
@@ -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;+}
+ example/prog4ok.ob view
@@ -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.
+ example/rec.ob view
@@ -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.
+ oberon0.cabal view
@@ -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 <mviera@fing.edu.uy>+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+
+ src/Language/Oberon0/L1/Decl.hs view
@@ -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])+
+ src/Language/Oberon0/L1/Gram.hs view
@@ -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"]+
+ src/Language/Oberon0/L1/SemT1.hs view
@@ -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 +
+ src/Language/Oberon0/L1/SemT2.hs view
@@ -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 ())
+ src/Language/Oberon0/L1/SemT3.hs view
@@ -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 ())
+ src/Language/Oberon0/L1/SemT5.hs view
@@ -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: _<module name>_ +-- 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 ())
+ src/Language/Oberon0/L1/T1.hs view
@@ -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
+ src/Language/Oberon0/L1/T2.hs view
@@ -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+
+ src/Language/Oberon0/L1/T3.hs view
@@ -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+
+ src/Language/Oberon0/L1/T5.hs view
@@ -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++
+ src/Language/Oberon0/L2/Decl.hs view
@@ -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
+ src/Language/Oberon0/L2/Gram.hs view
@@ -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"]+
+ src/Language/Oberon0/L2/SemT1.hs view
@@ -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 ++
+ src/Language/Oberon0/L2/SemT2.hs view
@@ -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 ()) ++
+ src/Language/Oberon0/L2/SemT3.hs view
@@ -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 ()) +
+ src/Language/Oberon0/L2/SemT5.hs view
@@ -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 ()) ++
+ src/Language/Oberon0/L2/T1.hs view
@@ -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
+ src/Language/Oberon0/L2/T2.hs view
@@ -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+
+ src/Language/Oberon0/L2/T3.hs view
@@ -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+
+ src/Language/Oberon0/L2/T5.hs view
@@ -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++
+ src/Language/Oberon0/L3/Decl.hs view
@@ -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+ +     }+
+ src/Language/Oberon0/L3/Gram.hs view
@@ -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"]+
+ src/Language/Oberon0/L3/SemT1.hs view
@@ -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+ +
+ src/Language/Oberon0/L3/SemT2.hs view
@@ -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 ())+
+ src/Language/Oberon0/L3/SemT3.hs view
@@ -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 ())+
+ src/Language/Oberon0/L3/SemT5.hs view
@@ -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 ())
+ src/Language/Oberon0/L3/T1.hs view
@@ -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
+ src/Language/Oberon0/L3/T2.hs view
@@ -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+
+ src/Language/Oberon0/L3/T3.hs view
@@ -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+
+ src/Language/Oberon0/L3/T5.hs view
@@ -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++
+ src/Language/Oberon0/L4/Decl.hs view
@@ -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])+
+ src/Language/Oberon0/L4/Gram.hs view
@@ -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"]+
+ src/Language/Oberon0/L4/SemT1.hs view
@@ -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+
+ src/Language/Oberon0/L4/SemT2.hs view
@@ -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 ())+
+ src/Language/Oberon0/L4/SemT3.hs view
@@ -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 ())+
+ src/Language/Oberon0/L4/SemT5.hs view
@@ -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 ())+
+ src/Language/Oberon0/L4/T1.hs view
@@ -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
+ src/Language/Oberon0/L4/T2.hs view
@@ -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
+ src/Language/Oberon0/L4/T3.hs view
@@ -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
+ src/Language/Oberon0/L4/T5.hs view
@@ -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++
+ src/Language/Oberon0/MainT1.hs view
@@ -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)+
+ src/Language/Oberon0/MainT2.hs view
@@ -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 () +
+ src/Language/Oberon0/MainT5.hs view
@@ -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 <stdio.h>\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)+