belka/elna
1
0
Fork 0
Code Issues 10 Pull Requests Releases Activity

Compare commits

merge into: belka:cpp
Branches Tags
belka:cpp
belka:haskell
belka:dlang
...
pull from: belka:haskell
Branches Tags
belka:cpp
belka:haskell
belka:dlang

No commits in common. "cpp" and "haskell" have entirely different histories.
cpp ... haskell

121 changed files with 4778 additions and 7258 deletions
Show Stats Expand all files Collapse all files

5
.gitignore vendored
View File

@ -1 +1,6 @@
/build/ /build/
.cache/
CMakeFiles/
CMakeCache.txt
node_modules/
/dist-newstyle/

674
COPYING3
View File

@ -1,674 +0,0 @@
GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The GNU General Public License is a free, copyleft license for
software and other kinds of works.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users. We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors. You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, 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
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.
To protect your rights, we need to prevent others from denying you
these rights or asking you to surrender the rights. Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received. You must make sure that they, too, receive
or can get the source code. And you must show them these terms so they
know their rights.
Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.
For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software. For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.
Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so. This is fundamentally incompatible with the aim of
protecting users' freedom to change the software. The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable. Therefore, we
have designed this version of the GPL to prohibit the practice for those
products. If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.
Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary. To prevent this, the GPL assures that
patents cannot be used to render the program non-free.
The precise terms and conditions for copying, distribution and
modification follow.
TERMS AND CONDITIONS
0. Definitions.
"This License" refers to version 3 of the GNU General Public License.
"Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.
"The Program" refers to any copyrightable work licensed under this
License. Each licensee is addressed as "you". "Licensees" and
"recipients" may be individuals or organizations.
To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy. The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.
A "covered work" means either the unmodified Program or a work based
on the Program.
To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy. Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.
To "convey" a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.
An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License. If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.
1. Source Code.
The "source code" for a work means the preferred form of the work
for making modifications to it. "Object code" means any non-source
form of a work.
A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.
The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form. A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.
The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities. However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work. For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.
The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.
The Corresponding Source for a work in source code form is that
same work.
2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work. This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.
You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force. You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright. Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.
Conveying under any other circumstances is permitted solely under
the conditions stated below. Sublicensing is not allowed; section 10
makes it unnecessary.
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.
4. Conveying Verbatim Copies.
You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:
a) The work must carry prominent notices stating that you modified
it, and giving a relevant date.
b) The work must carry prominent notices stating that it is
released under this License and any conditions added under section
7. This requirement modifies the requirement in section 4 to
"keep intact all notices".
c) You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable section 7
additional terms, to the whole of the work, and all its parts,
regardless of how they are packaged. This License gives no
permission to license the work in any other way, but it does not
invalidate such permission if you have separately received it.
d) If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has interactive
interfaces that do not display Appropriate Legal Notices, your
work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit. Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.
6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:
a) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
b) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that product
model, to give anyone who possesses the object code either (1) a
copy of the Corresponding Source for all the software in the
product that is covered by this License, on a durable physical
medium customarily used for software interchange, for a price no
more than your reasonable cost of physically performing this
conveying of source, or (2) access to copy the
Corresponding Source from a network server at no charge.
c) Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially, and
only if you received the object code with such an offer, in accord
with subsection 6b.
d) Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to the
Corresponding Source in the same way through the same place at no
further charge. You need not require recipients to copy the
Corresponding Source along with the object code. If the place to
copy the object code is a network server, the Corresponding Source
may be on a different server (operated by you or a third party)
that supports equivalent copying facilities, provided you maintain
clear directions next to the object code saying where to find the
Corresponding Source. Regardless of what server hosts the
Corresponding Source, you remain obligated to ensure that it is
available for as long as needed to satisfy these requirements.
e) Convey the object code using peer-to-peer transmission, provided
you inform other peers where the object code and Corresponding
Source of the work are being offered to the general public at no
charge under subsection 6d.
A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.
A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling. In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage. For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product. A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.
"Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source. The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.
If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information. But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).
The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed. Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.
Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.
7. Additional Terms.
"Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law. If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:
a) Disclaiming warranty or limiting liability differently from the
terms of sections 15 and 16 of this License; or
b) Requiring preservation of specified reasonable legal notices or
author attributions in that material or in the Appropriate Legal
Notices displayed by works containing it; or
c) Prohibiting misrepresentation of the origin of that material, or
requiring that modified versions of such material be marked in
reasonable ways as different from the original version; or
d) Limiting the use for publicity purposes of names of licensors or
authors of the material; or
e) Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
f) Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified versions of
it) with contractual assumptions of liability to the recipient, for
any liability that these contractual assumptions directly impose on
those licensors and authors.
All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10. If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term. If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.
8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.
9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or
run a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance. However,
nothing other than this License grants you permission to propagate or
modify any covered work. These actions infringe copyright if you do
not accept this License. Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.
10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not responsible
for enforcing compliance by third parties with this License.
An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.
11. Patents.
A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based. The
work thus licensed is called the contributor's "contributor version".
A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version. For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.
Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.
In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement). To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.
If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients. "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.
A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License. You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
12. No Surrender of Others' Freedom.
If 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 convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all. For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.
13. Use with the GNU Affero General Public License.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a single
combined work, and to convey the resulting work. The terms of this
License will continue to apply to the part which is the covered work,
but the special requirements of the GNU Affero General Public License,
section 13, concerning interaction through a network will apply to the
combination as such.
14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new versions of
the GNU 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
Program specifies that a certain numbered version of the GNU General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation. If the Program does not specify a version number of the
GNU General Public License, you may choose any version ever published
by the Free Software Foundation.
If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "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 PROGRAM
IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM 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 PROGRAM (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 PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
state 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 program's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Also add information on how to contact you by electronic and paper mail.
If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:
<program> Copyright (C) <year> <name of author>
This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, your program's commands
might be different; for a GUI interface, you would use an "about box".
You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU GPL, see
<http://www.gnu.org/licenses/>.
The GNU General Public License does not permit incorporating your program
into proprietary programs. If your program is a subroutine library, you
may consider it more useful to permit linking proprietary applications with
the library. If this is what you want to do, use the GNU Lesser General
Public License instead of this License. But first, please read
<http://www.gnu.org/philosophy/why-not-lgpl.html>.

37
README Normal file
View File

@ -0,0 +1,37 @@
# Elna programming language
Elna compiles simple mathematical operations to machine code.
The compiled program returns the result of the operation.
## File extension
.elna
## Grammar PL/0
program = block "." ;
block = [ "const" ident "=" number {"," ident "=" number} ";"]
[ "var" ident {"," ident} ";"]
{ "procedure" ident ";" block ";" } statement ;
statement = [ ident ":=" expression | "call" ident
| "?" ident | "!" expression
| "begin" statement {";" statement } "end"
| "if" condition "then" statement
| "while" condition "do" statement ];
condition = "odd" expression |
expression ("="|"#"|"<"|"<="|">"|">=") expression ;
expression = [ "+"|"-"] term { ("+"|"-") term};
term = factor {("*"|"/") factor};
factor = ident | number | "(" expression ")";
## Operations
"!" - Write a line.
"?" - Read user input.
"odd" - The only function, returns whether a number is odd.

45
README.md
View File

@ -1,45 +0,0 @@
# Elna programming language
Elna is a simple, imperative, low-level programming language.
It is intendet to accompany other languages in the areas, where a high-level
language doesn't fit well. It is also supposed to be an intermediate
representation for a such high-level hypothetical programming language.
## File extension
.elna
## Current implementation
This repository contains a GCC frontend for Elna. After finishing the frontend
I'm planning to rewrite the compiler in Elna itself with its own backend and
a hand-written parser. So GCC gives a way to have a simple bootstrap compiler
and a possbility to compile Elna programs for different platforms.
## Grammar
Flex and bison grammar specifications, `lexer.ll` and `parser.yy`, can be found
in the `boot/` directory.
## Build
The frontend requires GCC 14.2.0 (not tested with other versions).
Download the GCC source. Copy the contents of this repository into `gcc/elna`
inside GCC. Finally build GCC enabling the frontend with
`--enable-languages=c,c++,elna`. After the installation the compiler can be
invoked with `$prefix/bin/gelna`.
There is also a `Rakefile` that downloads, builds and installs GCC into the
`./build/` subdirectory. The `Rakefile` assumes that ruby and rake, as well as
all GCC dependencies are already available in the system. It works under Linux
and Mac OS. In the latter case GCC is patched with the patches used by Homebrew
(official GCC doesn't support Apple silicon targets). Invoke with
```sh
rake boot
```
See `rake -T` for more tasks. The GCC source is under `build/tools`. The
installation path is `build/host/install`.

182
Rakefile
View File

@ -1,182 +0,0 @@
# This Source Code Form is subject to the terms of the Mozilla Public License,
# v. 2.0. If a copy of the MPL was not distributed with this file, You can
# obtain one at https://mozilla.org/MPL/2.0/. -}
require 'pathname'
require 'open3'
require 'rake/clean'
require_relative 'tools/support'
# Dependencies.
GCC_VERSION = "14.2.0"
GCC_PATCH = 'https://raw.githubusercontent.com/Homebrew/formula-patches/f30c309442a60cfb926e780eae5d70571f8ab2cb/gcc/gcc-14.2.0-r2.diff'
# Paths.
HOST_GCC = TMP + 'host/gcc'
HOST_INSTALL = TMP + 'host/install'
CLOBBER.include TMP
directory(TMP + 'tools')
directory HOST_GCC
directory HOST_INSTALL
task default: [TMP + 'elna'] do
sh (TMP + 'elna').to_path, '--tokenize', 'source.elna'
end
namespace :boot do
desc 'Download and configure the bootstrap compiler'
task configure: [TMP + 'tools', HOST_GCC, HOST_INSTALL] do
url = URI.parse "https://gcc.gnu.org/pub/gcc/releases/gcc-#{GCC_VERSION}/gcc-#{GCC_VERSION}.tar.xz"
options = find_build_target GCC_VERSION
source_directory = TMP + "tools/gcc-#{GCC_VERSION}"
frontend_link = source_directory + 'gcc'
download_and_pipe url, source_directory.dirname, ['tar', '-Jxv']
download_and_pipe URI.parse(GCC_PATCH), source_directory, ['patch', '-p1']
sh 'contrib/download_prerequisites', chdir: source_directory.to_path
File.symlink Pathname.new('.').relative_path_from(frontend_link), (frontend_link + 'elna')
configure_options = [
"--prefix=#{HOST_INSTALL.realpath}",
"--with-sysroot=#{options.sysroot.realpath}",
'--enable-languages=c,c++,elna',
'--disable-bootstrap',
'--disable-multilib',
"--target=#{options.build}",
"--build=#{options.build}",
"--host=#{options.build}"
]
flags = '-O2 -fPIC -I/opt/homebrew/Cellar/flex/2.6.4_2/include'
env = {
'CC' => options.gcc,
'CXX' => options.gxx,
'CFLAGS' => flags,
'CXXFLAGS' => flags,
}
configure = source_directory.relative_path_from(HOST_GCC) + 'configure'
sh env, configure.to_path, *configure_options, chdir: HOST_GCC.to_path
end
desc 'Make and install the bootstrap compiler'
task :make do
cwd = HOST_GCC.to_path
sh 'make', '-j', Etc.nprocessors.to_s, chdir: cwd
sh 'make', 'install', chdir: cwd
end
end
desc 'Build the bootstrap compiler'
task boot: %w[boot:configure boot:make]
file (TMP + 'elna').to_path => ['source.elna']
file (TMP + 'elna').to_path => [(HOST_INSTALL + 'bin/gelna').to_path] do |task|
sh (HOST_INSTALL + 'bin/gelna').to_path, '-o', task.name, task.prerequisites.first
end
namespace :cross do
desc 'Build cross toolchain'
task :init, [:target] do |_, args|
args.with_defaults target: 'riscv32-unknown-linux-gnu'
options = find_build_target GCC_VERSION, args[:target]
env = {
'PATH' => "#{options.rootfs.realpath + 'bin'}:#{ENV['PATH']}"
}
sh env, 'riscv32-unknown-linux-gnu-gcc',
'-ffreestanding', '-static',
'-o', (options.tools + 'init').to_path,
'tools/init.c'
end
end
namespace :test do
test_sources = FileList['tests/vm/*.elna', 'tests/vm/*.s']
compiler = TMP + 'bin/elna'
object_directory = TMP + 'riscv/tests'
root_directory = TMP + 'riscv/root'
executable_directory = root_directory + 'tests'
expectation_directory = root_directory + 'expectations'
init = TMP + 'riscv/root/init'
builtin = TMP + 'riscv/builtin.o'
directory root_directory
directory object_directory
directory executable_directory
directory expectation_directory
file builtin => ['tools/builtin.s', object_directory] do |task|
sh AS, '-o', task.name, task.prerequisites.first
end
test_files = test_sources.flat_map do |test_source|
test_basename = File.basename(test_source, '.*')
test_object = object_directory + test_basename.ext('.o')
file test_object => [test_source, object_directory] do |task|
case File.extname(task.prerequisites.first)
when '.s'
sh AS, '-mno-relax', '-o', task.name, task.prerequisites.first
when '.elna'
sh compiler, '--output', task.name, task.prerequisites.first
else
raise "Unknown source file extension #{task.prerequisites.first}"
end
end
test_executable = executable_directory + test_basename
file test_executable => [test_object, executable_directory, builtin] do |task|
objects = task.prerequisites.filter { |prerequisite| File.file? prerequisite }
sh LINKER, '-o', test_executable.to_path, *objects
end
expectation_name = test_basename.ext '.txt'
source_expectation = "tests/expectations/#{expectation_name}"
target_expectation = expectation_directory + expectation_name
file target_expectation => [source_expectation, expectation_directory] do
cp source_expectation, target_expectation
end
[test_executable, target_expectation]
end
file init => [root_directory] do |task|
cp (TMP + 'tools/init'), task.name
end
# Directories should come first.
test_files.unshift executable_directory, expectation_directory, init
file (TMP + 'riscv/root.cpio') => test_files do |task|
root_files = task.prerequisites
.map { |prerequisite| Pathname.new(prerequisite).relative_path_from(root_directory).to_path }
File.open task.name, 'wb' do |cpio_file|
cpio_options = {
chdir: root_directory.to_path
}
cpio_stream = Open3.popen2 'cpio', '-o', '--format=newc', cpio_options do |stdin, stdout, wait_thread|
stdin.write root_files.join("\n")
stdin.close
stdout.each { |chunk| cpio_file.write chunk }
wait_thread.value
end
end
end
task :vm => (TMP + 'riscv/root.cpio') do |task|
kernels = FileList.glob(TMP + 'tools/linux-*/arch/riscv/boot/Image')
sh 'qemu-system-riscv32',
'-nographic',
'-M', 'virt',
'-bios', 'default',
'-kernel', kernels.first,
'-append', 'quiet panic=1',
'-initrd', task.prerequisites.first,
'-no-reboot'
end
end

10
TODO Normal file
View File

@ -0,0 +1,10 @@
# ELF generation
- Don't ignore relocations where the symbol is not defined in the symbol table.
Report an error about an undefined symbol.
# Register allocation
- Each temporary variable gets a tn register where n is the variable index. If
there more variables the allocation will fail with out of bounds runtime
error. Implement spill over.

999
boot/ast.cc
View File

@ -1,999 +0,0 @@
/* Abstract syntax tree representation.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "elna/boot/ast.h"
namespace elna
{
namespace boot
{
void empty_visitor::visit(variable_declaration *)
{
}
void empty_visitor::visit(constant_definition *definition)
{
definition->body().accept(this);
}
void empty_visitor::visit(procedure_definition *definition)
{
for (auto parameter : definition->parameters)
{
parameter->accept(this);
}
if (definition->body() != nullptr)
{
definition->body()->accept(this);
}
}
void empty_visitor::visit(type_definition *definition)
{
definition->body().accept(this);
}
void empty_visitor::visit(call_expression *expression)
{
for (auto& argument : expression->arguments())
{
argument->accept(this);
}
}
void empty_visitor::visit(cast_expression *expression)
{
expression->target().accept(this);
expression->value().accept(this);
}
void empty_visitor::visit(type_expression *expression)
{
expression->body().accept(this);
}
void empty_visitor::visit(call_statement *statement)
{
statement->body().accept(this);
}
void empty_visitor::visit(assign_statement *statement)
{
statement->rvalue().accept(this);
}
void empty_visitor::visit(if_statement *statement)
{
statement->body().prerequisite().accept(this);
for (const auto body_statement : statement->body().statements)
{
body_statement->accept(this);
}
}
void empty_visitor::visit(while_statement *statement)
{
statement->body().prerequisite().accept(this);
for (const auto body_statement : statement->body().statements)
{
body_statement->accept(this);
}
}
void empty_visitor::visit(return_statement *statement)
{
expression *return_expression = statement->return_expression();
if (return_expression != nullptr)
{
return_expression->accept(this);
}
}
void empty_visitor::visit(defer_statement *defer)
{
for (statement *const body_statement : defer->statements)
{
body_statement->accept(this);
}
}
void empty_visitor::visit(block *block)
{
for (constant_definition *const constant : block->constants)
{
constant->accept(this);
}
for (variable_declaration *const variable : block->variables)
{
variable->accept(this);
}
for (statement *const body_statement : block->body)
{
body_statement->accept(this);
}
}
void empty_visitor::visit(program *program)
{
visit(reinterpret_cast<block *>(program));
for (type_definition *const type : program->types)
{
type->accept(this);
}
for (procedure_definition *const procedure : program->procedures)
{
procedure->accept(this);
}
}
void empty_visitor::visit(binary_expression *expression)
{
expression->lhs().accept(this);
expression->rhs().accept(this);
}
void empty_visitor::visit(unary_expression *expression)
{
expression->operand().accept(this);
}
void empty_visitor::visit(basic_type *)
{
}
void empty_visitor::visit(array_type *expression)
{
expression->base().accept(this);
}
void empty_visitor::visit(pointer_type *expression)
{
expression->base().accept(this);
}
void empty_visitor::visit(record_type *expression)
{
for (auto& field : expression->fields)
{
field.second->accept(this);
}
}
void empty_visitor::visit(union_type *expression)
{
for (auto& field : expression->fields)
{
field.second->accept(this);
}
}
void empty_visitor::visit(variable_expression *)
{
}
void empty_visitor::visit(array_access_expression *expression)
{
expression->base().accept(this);
expression->index().accept(this);
}
void empty_visitor::visit(field_access_expression *expression)
{
expression->base().accept(this);
}
void empty_visitor::visit(dereference_expression *expression)
{
expression->base().accept(this);
}
void empty_visitor::visit(number_literal<std::int32_t> *)
{
}
void empty_visitor::visit(number_literal<std::uint32_t> *)
{
}
void empty_visitor::visit(number_literal<double> *)
{
}
void empty_visitor::visit(number_literal<bool> *)
{
}
void empty_visitor::visit(number_literal<unsigned char> *)
{
}
void empty_visitor::visit(number_literal<std::nullptr_t> *)
{
}
void empty_visitor::visit(number_literal<std::string> *)
{
}
node::node(const struct position position)
: source_position(position)
{
}
const struct position& node::position() const
{
return this->source_position;
}
statement::statement(const struct position position)
: node(position)
{
}
expression::expression(const struct position position)
: node(position)
{
}
top_type::top_type(const struct position position)
: node(position)
{
}
basic_type *top_type::is_basic()
{
return nullptr;
}
array_type *top_type::is_array()
{
return nullptr;
}
record_type *top_type::is_record()
{
return nullptr;
}
union_type *top_type::is_union()
{
return nullptr;
}
pointer_type *top_type::is_pointer()
{
return nullptr;
}
basic_type::basic_type(const struct position position, const std::string& name)
: top_type(position), m_name(name)
{
}
void basic_type::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
const std::string& basic_type::base_name()
{
return m_name;
}
basic_type *basic_type::is_basic()
{
return this;
}
array_type::array_type(const struct position position, std::shared_ptr<top_type> base, const std::uint32_t size)
: top_type(position), m_base(base), size(size)
{
}
void array_type::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
top_type& array_type::base()
{
return *m_base;
}
array_type*array_type::is_array()
{
return this;
}
pointer_type::pointer_type(const struct position position, std::shared_ptr<top_type> base)
: top_type(position), m_base(base)
{
}
void pointer_type::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
top_type& pointer_type::base()
{
return *m_base;
}
pointer_type *pointer_type::is_pointer()
{
return this;
}
composite_type::composite_type(const struct position position, fields_t&& fields)
: top_type(position), fields(std::move(fields))
{
}
record_type::record_type(const struct position position, fields_t&& fields)
: composite_type(position, std::move(fields))
{
}
void record_type::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
record_type *record_type::is_record()
{
return this;
}
union_type::union_type(const struct position position, fields_t&& fields)
: composite_type(position, std::move(fields))
{
}
union_type *union_type::is_union()
{
return this;
}
void union_type::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
variable_declaration::variable_declaration(const struct position position, const std::string& identifier,
std::shared_ptr<top_type> type, const bool exported)
: definition(position, identifier, exported), m_type(type)
{
}
void variable_declaration::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
top_type& variable_declaration::variable_type()
{
return *m_type;
}
definition::definition(const struct position position, const std::string& identifier, const bool exported)
: node(position), identifier(identifier), exported(exported)
{
}
constant_definition::constant_definition(const struct position position, const std::string& identifier,
const bool exported, literal *body)
: definition(position, identifier, exported), m_body(body)
{
}
void constant_definition::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
literal& constant_definition::body()
{
return *m_body;
}
constant_definition::~constant_definition()
{
delete m_body;
}
procedure_definition::procedure_definition(const struct position position, const std::string& identifier,
const bool exported, std::shared_ptr<top_type> return_type)
: definition(position, identifier, exported), m_return_type(return_type), no_return{ false }
{
}
procedure_definition::procedure_definition(const struct position position, const std::string& identifier,
const bool exported, no_return_t)
: definition(position, identifier, exported), m_return_type(nullptr), no_return{ true }
{
}
void procedure_definition::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
block *procedure_definition::body()
{
return m_body;
}
procedure_definition *procedure_definition::add_body(block *procedure_body)
{
m_body = procedure_body;
return this;
}
std::shared_ptr<top_type> procedure_definition::return_type()
{
return m_return_type;
}
procedure_definition::~procedure_definition()
{
if (m_body != nullptr)
{
delete m_body;
}
for (auto parameter : parameters)
{
delete parameter;
}
}
type_definition::type_definition(const struct position position, const std::string& identifier,
const bool exported, std::shared_ptr<top_type> body)
: definition(position, identifier, exported), m_body(body)
{
}
void type_definition::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
top_type& type_definition::body()
{
return *m_body;
}
block::block(const struct position position)
: node(position)
{
}
void block::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
block::~block()
{
for (statement *body_statement : this->body)
{
delete body_statement;
}
for (variable_declaration *variable : this->variables)
{
delete variable;
}
for (constant_definition *constant : this->constants)
{
delete constant;
}
}
program::program(const struct position position)
: block(position)
{
}
void program::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
program::~program()
{
for (procedure_definition *procedure : this->procedures)
{
delete procedure;
}
for (type_definition *type : this->types)
{
delete type;
}
}
literal::literal(const struct position position)
: expression(position)
{
}
defer_statement::defer_statement(const struct position position)
: statement(position)
{
}
void defer_statement::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
defer_statement::~defer_statement()
{
for (statement *body_statement : statements)
{
delete body_statement;
}
}
designator_expression::designator_expression(const struct position position)
: expression(position)
{
}
variable_expression::variable_expression(const struct position position, const std::string& name)
: designator_expression(position), m_name(name)
{
}
void variable_expression::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
const std::string& variable_expression::name() const
{
return m_name;
}
variable_expression *variable_expression::is_variable()
{
return this;
}
array_access_expression::array_access_expression(const struct position position,
expression *base, expression *index)
: designator_expression(position), m_base(base), m_index(index)
{
}
void array_access_expression::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
expression& array_access_expression::index()
{
return *m_index;
}
expression& array_access_expression::base()
{
return *m_base;
}
array_access_expression *array_access_expression::is_array_access()
{
return this;
}
array_access_expression::~array_access_expression()
{
delete m_index;
delete m_base;
}
field_access_expression::field_access_expression(const struct position position,
expression *base, const std::string& field)
: designator_expression(position), m_base(base), m_field(field)
{
}
void field_access_expression::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
expression& field_access_expression::base()
{
return *m_base;
}
std::string& field_access_expression::field()
{
return m_field;
}
field_access_expression *field_access_expression::is_field_access()
{
return this;
}
field_access_expression::~field_access_expression()
{
delete m_base;
}
dereference_expression::dereference_expression(const struct position position,
expression *base)
: designator_expression(position), m_base(base)
{
}
void dereference_expression::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
expression& dereference_expression::base()
{
return *m_base;
}
dereference_expression *dereference_expression::is_dereference()
{
return this;
}
dereference_expression::~dereference_expression()
{
delete m_base;
}
binary_expression::binary_expression(const struct position position, expression *lhs,
expression *rhs, const binary_operator operation)
: expression(position), m_lhs(lhs), m_rhs(rhs), m_operator(operation)
{
}
void binary_expression::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
expression& binary_expression::lhs()
{
return *m_lhs;
}
expression& binary_expression::rhs()
{
return *m_rhs;
}
binary_operator binary_expression::operation() const
{
return m_operator;
}
binary_expression::~binary_expression()
{
delete m_lhs;
delete m_rhs;
}
unary_expression::unary_expression(const struct position position, expression *operand,
const unary_operator operation)
: expression(position), m_operand(std::move(operand)), m_operator(operation)
{
}
void unary_expression::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
expression& unary_expression::operand()
{
return *m_operand;
}
unary_operator unary_expression::operation() const
{
return this->m_operator;
}
unary_expression::~unary_expression()
{
delete m_operand;
}
call_expression::call_expression(const struct position position, const std::string& name)
: expression(position), m_name(name)
{
}
void call_expression::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
std::string& call_expression::name()
{
return m_name;
}
std::vector<expression *>& call_expression::arguments()
{
return m_arguments;
}
call_expression::~call_expression()
{
for (auto argument : m_arguments)
{
delete argument;
}
}
cast_expression::cast_expression(const struct position position,
std::shared_ptr<top_type> target, expression *value)
: expression(position), m_target(target), m_value(value)
{
}
void cast_expression::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
top_type& cast_expression::target()
{
return *m_target;
}
expression& cast_expression::value()
{
return *m_value;
}
cast_expression::~cast_expression()
{
delete m_value;
}
type_expression::type_expression(const struct position position, std::shared_ptr<top_type> body)
: expression(position), m_body(body)
{
}
void type_expression::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
top_type& type_expression::body()
{
return *m_body;
}
call_statement::call_statement(const struct position position, call_expression *body)
: statement(position), m_body(body)
{
}
void call_statement::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
call_expression& call_statement::body()
{
return *m_body;
}
call_statement::~call_statement()
{
delete m_body;
}
conditional_statements::conditional_statements(expression *prerequisite)
: m_prerequisite(prerequisite)
{
}
expression& conditional_statements::prerequisite()
{
return *m_prerequisite;
}
conditional_statements::~conditional_statements()
{
delete m_prerequisite;
for (auto statement : statements)
{
delete statement;
}
}
return_statement::return_statement(const struct position position, expression *return_expression)
: statement(position), m_return_expression(return_expression)
{
}
void return_statement::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
expression *return_statement::return_expression()
{
return m_return_expression;
}
return_statement::~return_statement()
{
if (m_return_expression != nullptr)
{
delete m_return_expression;
}
}
void assign_statement::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
assign_statement::assign_statement(const struct position position, designator_expression *lvalue,
expression *rvalue)
: statement(position), m_lvalue(lvalue), m_rvalue(rvalue)
{
}
variable_expression *designator_expression::is_variable()
{
return nullptr;
}
array_access_expression *designator_expression::is_array_access()
{
return nullptr;
}
field_access_expression *designator_expression::is_field_access()
{
return nullptr;
}
dereference_expression *designator_expression::is_dereference()
{
return nullptr;
}
designator_expression& assign_statement::lvalue()
{
return *m_lvalue;
}
expression& assign_statement::rvalue()
{
return *m_rvalue;
}
assign_statement::~assign_statement()
{
delete m_rvalue;
}
if_statement::if_statement(const struct position position, conditional_statements *body,
std::vector<statement *> *alternative)
: statement(position), m_body(body), m_alternative(alternative)
{
}
void if_statement::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
conditional_statements& if_statement::body()
{
return *m_body;
}
std::vector<statement *> *if_statement::alternative()
{
return m_alternative;
}
if_statement::~if_statement()
{
delete m_body;
for (const auto branch : branches)
{
delete branch;
}
if (m_alternative != nullptr)
{
delete m_alternative;
}
}
while_statement::while_statement(const struct position position, conditional_statements *body)
: statement(position), m_body(body)
{
}
void while_statement::accept(parser_visitor *visitor)
{
visitor->visit(this);
}
conditional_statements& while_statement::body()
{
return *m_body;
}
while_statement::~while_statement()
{
delete m_body;
for (const auto branch : branches)
{
delete branch;
}
}
const char *print_binary_operator(const binary_operator operation)
{
switch (operation)
{
case binary_operator::sum:
return "+";
case binary_operator::subtraction:
return "-";
case binary_operator::multiplication:
return "*";
case binary_operator::division:
return "/";
case binary_operator::remainder:
return "%";
case binary_operator::equals:
return "=";
case binary_operator::not_equals:
return "<>";
case binary_operator::less:
return "<";
case binary_operator::less_equal:
return "<=";
case binary_operator::greater:
return ">";
case binary_operator::greater_equal:
return ">=";
case binary_operator::conjunction:
return "and";
case binary_operator::disjunction:
return "or";
case binary_operator::exclusive_disjunction:
return "xor";
case binary_operator::shift_left:
return "<<";
case binary_operator::shift_right:
return ">>";
}
__builtin_unreachable();
};
}
}

92
boot/driver.cc
View File

@ -1,92 +0,0 @@
/* Parsing driver.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "elna/boot/driver.h"
namespace elna
{
namespace boot
{
position make_position(const yy::location& location)
{
position result;
result.line = static_cast<std::size_t>(location.begin.line);
result.column = static_cast<std::size_t>(location.begin.column);
return result;
}
syntax_error::syntax_error(const std::string& message,
const char *input_file, const yy::location& location)
: error(input_file, make_position(location)), message(message)
{
}
std::string syntax_error::what() const
{
return message;
}
driver::driver(const char *input_file)
: input_file(input_file)
{
}
void driver::error(const yy::location& loc, const std::string& message)
{
m_errors.emplace_back(new boot::syntax_error(message, input_file, loc));
}
const std::list<std::unique_ptr<struct error>>& driver::errors() const noexcept
{
return m_errors;
}
char escape_char(char escape)
{
switch (escape)
{
case 'n':
return '\n';
case 'a':
return '\a';
case 'b':
return '\b';
case 't':
return '\t';
case 'f':
return '\f';
case 'r':
return '\r';
case 'v':
return '\v';
case '\\':
return '\\';
case '\'':
return '\'';
case '"':
return '"';
case '?':
return '\?';
case '0':
return '\0';
default:
return escape_invalid_char;
}
}
}
}

292
boot/lexer.ll
View File

@ -1,292 +0,0 @@
/* Lexical analyzer.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
%{
#define YY_NO_UNISTD_H
#define YY_USER_ACTION this->location.columns(yyleng);
#include <sstream>
#include "parser.hh"
#undef YY_DECL
#define YY_DECL yy::parser::symbol_type elna::boot::lexer::lex(elna::boot::driver& driver)
#define yyterminate() return yy::parser::make_YYEOF(this->location)
%}
%option c++ noyywrap never-interactive
%option yyclass="elna::boot::lexer"
%x IN_COMMENT
%%
%{
this->location.step();
%}
<IN_COMMENT>{
\*\) BEGIN(INITIAL);
[^*\n]+ ; /* Eat comment in chunks. */
\* ; /* Eat the lone star. */
\n+ {
this->location.lines(yyleng);
this->location.step();
}
}
\(\* BEGIN(IN_COMMENT);
[ \t\r] {
this->location.step();
}
\n+ {
this->location.lines(yyleng);
}
if {
return yy::parser::make_IF(this->location);
}
then {
return yy::parser::make_THEN(this->location);
}
else {
return yy::parser::make_ELSE(this->location);
}
elsif {
return yy::parser::make_ELSIF(this->location);
}
while {
return yy::parser::make_WHILE(this->location);
}
do {
return yy::parser::make_DO(this->location);
}
proc {
return yy::parser::make_PROCEDURE(this->location);
}
begin {
return yy::parser::make_BEGIN_BLOCK(this->location);
}
end {
return yy::parser::make_END_BLOCK(this->location);
}
extern {
return yy::parser::make_EXTERN(this->location);
}
const {
return yy::parser::make_CONST(this->location);
}
var {
return yy::parser::make_VAR(this->location);
}
type {
return yy::parser::make_TYPE(this->location);
}
record {
return yy::parser::make_RECORD(this->location);
}
union {
return yy::parser::make_UNION(this->location);
}
true {
return yy::parser::make_BOOLEAN(true, this->location);
}
false {
return yy::parser::make_BOOLEAN(false, this->location);
}
nil {
return yy::parser::make_NIL(this->location);
}
and {
return yy::parser::make_AND(this->location);
}
xor {
return yy::parser::make_XOR(this->location);
}
or {
return yy::parser::make_OR(this->location);
}
not {
return yy::parser::make_NOT(this->location);
}
return {
return yy::parser::make_RETURN(this->location);
}
cast {
return yy::parser::make_CAST(this->location);
}
defer {
return yy::parser::make_DEFER(this->location);
}
[A-Za-z_][A-Za-z0-9_]* {
return yy::parser::make_IDENTIFIER(yytext, this->location);
}
[0-9]+u {
return yy::parser::make_WORD(strtoul(yytext, NULL, 10), this->location);
}
[0-9]+ {
return yy::parser::make_INTEGER(strtol(yytext, NULL, 10), this->location);
}
[0-9]+\.[0-9] {
return yy::parser::make_FLOAT(strtof(yytext, NULL), this->location);
}
'[[:print:]]' {
if (yytext[1] == '\\' || yytext[1] == '\'')
{
REJECT;
}
else
{
return yy::parser::make_CHARACTER(std::string(yytext, 1, 1), this->location);
}
}
'\\x[0-9a-fA-F]{1,2}' {
char character = static_cast<char>(std::stoi(yytext + 3, nullptr, 16));
return yy::parser::make_CHARACTER(std::string(&character, 1), this->location);
}
'\\[0nabtfrv\\'"?]' {
char escape = elna::boot::escape_char(yytext[2]);
if (escape == escape_invalid_char)
{
REJECT;
}
return yy::parser::make_CHARACTER(std::string(&escape, 1), this->location);
}
\"[[:print:]]*\" {
std::string result;
const char *current_position = yytext + 1;
while (*current_position != '\0')
{
if (*current_position == '\\' && *(current_position + 1) == 'x')
{
current_position += 2;
std::size_t processed;
char character = static_cast<char>(std::stoi(current_position, &processed, 16));
if (processed == 0)
{
REJECT;
}
else
{
current_position += processed - 1;
result.push_back(character);
}
}
else if (*current_position == '\\')
{
++current_position;
char escape = elna::boot::escape_char(*current_position);
if (escape == elna::boot::escape_invalid_char)
{
REJECT;
}
result.push_back(escape);
}
else
{
result.push_back(*current_position);
}
++current_position;
}
result.pop_back();
return yy::parser::make_STRING(result, this->location);
}
\( {
return yy::parser::make_LEFT_PAREN(this->location);
}
\) {
return yy::parser::make_RIGHT_PAREN(this->location);
}
\[ {
return yy::parser::make_LEFT_SQUARE(this->location);
}
\] {
return yy::parser::make_RIGHT_SQUARE(this->location);
}
\<\< {
return yy::parser::make_SHIFT_LEFT(this->location);
}
\>\> {
return yy::parser::make_SHIFT_RIGHT(this->location);
}
\>= {
return yy::parser::make_GREATER_EQUAL(this->location);
}
\<= {
return yy::parser::make_LESS_EQUAL(this->location);
}
\> {
return yy::parser::make_GREATER_THAN(this->location);
}
\< {
return yy::parser::make_LESS_THAN(this->location);
}
\<\> {
return yy::parser::make_NOT_EQUAL(this->location);
}
= {
return yy::parser::make_EQUALS(this->location);
}
; {
return yy::parser::make_SEMICOLON(this->location);
}
\. {
return yy::parser::make_DOT(this->location);
}
, {
return yy::parser::make_COMMA(this->location);
}
\+ {
return yy::parser::make_PLUS(this->location);
}
\-> {
return yy::parser::make_ARROW(this->location);
}
\- {
return yy::parser::make_MINUS(this->location);
}
\* {
return yy::parser::make_MULTIPLICATION(this->location);
}
\/ {
return yy::parser::make_DIVISION(this->location);
}
% {
return yy::parser::make_REMAINDER(this->location);
}
:= {
return yy::parser::make_ASSIGNMENT(this->location);
}
: {
return yy::parser::make_COLON(this->location);
}
\^ {
return yy::parser::make_HAT(this->location);
}
@ {
return yy::parser::make_AT(this->location);
}
! {
return yy::parser::make_EXCLAMATION(this->location);
}
. {
std::stringstream ss;
ss << "Illegal character 0x" << std::hex << static_cast<unsigned int>(yytext[0]);
driver.error(this->location, ss.str());
}
%%

546
boot/parser.yy
View File

@ -1,546 +0,0 @@
/* Syntax analyzer.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
%require "3.4"
%language "c++"
%code requires {
#include <cstdint>
#include <iostream>
#include "elna/boot/driver.h"
#if !defined(yyFlexLexerOnce)
#include <FlexLexer.h>
#endif
namespace elna
{
namespace boot
{
class lexer;
}
}
}
%code provides {
namespace elna
{
namespace boot
{
class lexer: public yyFlexLexer
{
public:
yy::location location;
lexer(std::istream& arg_yyin)
: yyFlexLexer(&arg_yyin)
{
}
yy::parser::symbol_type lex(elna::boot::driver& driver);
};
}
}
}
%define api.token.raw
%define api.token.constructor
%define api.value.type variant
%parse-param {elna::boot::lexer& lexer}
%param {elna::boot::driver& driver}
%locations
%header
%code {
#define yylex lexer.lex
}
%start program;
%token <std::string> IDENTIFIER "identifier"
%token <std::int32_t> INTEGER "integer"
%token <std::uint32_t> WORD "word"
%token <float> FLOAT "float"
%token <std::string> CHARACTER "character"
%token <std::string> STRING "string"
%token <bool> BOOLEAN
%token IF WHILE DO THEN ELSE ELSIF RETURN
%token CONST VAR PROCEDURE TYPE RECORD UNION
%token BEGIN_BLOCK END_BLOCK EXTERN DEFER
%token LEFT_PAREN RIGHT_PAREN LEFT_SQUARE RIGHT_SQUARE SEMICOLON DOT COMMA
%token NOT CAST EXCLAMATION
%token ASSIGNMENT COLON HAT AT NIL ARROW
%left OR AND XOR
%left EQUALS NOT_EQUAL LESS_THAN GREATER_THAN LESS_EQUAL GREATER_EQUAL
%left SHIFT_LEFT SHIFT_RIGHT
%left PLUS MINUS
%left MULTIPLICATION DIVISION REMAINDER
%type <elna::boot::literal *> literal;
%type <elna::boot::constant_definition *> constant_definition;
%type <std::vector<elna::boot::constant_definition *>> constant_part constant_definitions;
%type <std::vector<elna::boot::variable_declaration *>> variable_declarations variable_part variable_declaration
formal_parameters formal_parameter_list;
%type <elna::boot::variable_declaration *> formal_parameter
%type <std::shared_ptr<elna::boot::top_type>> type_expression;
%type <elna::boot::expression *> expression operand unary;
%type <std::vector<elna::boot::expression *>> expressions actual_parameter_list;
%type <elna::boot::designator_expression *> designator_expression;
%type <elna::boot::assign_statement *> assign_statement;
%type <elna::boot::call_expression *> call_expression;
%type <elna::boot::while_statement *> while_statement;
%type <elna::boot::if_statement *> if_statement;
%type <elna::boot::return_statement *> return_statement;
%type <elna::boot::statement *> statement;
%type <std::vector<elna::boot::statement *>> statements optional_statements;
%type <elna::boot::procedure_definition *> procedure_definition procedure_heading;
%type <std::vector<elna::boot::procedure_definition *>> procedure_definitions procedure_part;
%type <elna::boot::type_definition *> type_definition;
%type <std::vector<elna::boot::type_definition *>> type_definitions type_part;
%type <elna::boot::block *> block;
%type <elna::boot::field_t> field_declaration;
%type <std::vector<std::pair<std::string, std::shared_ptr<elna::boot::top_type>>>> optional_fields fields;
%type <std::vector<elna::boot::conditional_statements *>> elsif_then_statements elsif_do_statements;
%type <elna::boot::cast_expression *> cast_expression;
%type <elna::boot::defer_statement *> defer_statement;
%type <std::pair<std::string, bool>> identifier_definition;
%type <std::vector<std::pair<std::string, bool>>> identifier_definitions;
%%
program:
constant_part type_part variable_part procedure_part BEGIN_BLOCK optional_statements END_BLOCK DOT
{
auto tree = new elna::boot::program(elna::boot::make_position(@5));
std::swap(tree->constants, $1);
std::swap(tree->types , $2);
std::swap(tree->variables, $3);
std::swap(tree->procedures, $4);
std::swap(tree->body, $6);
driver.tree.reset(tree);
}
block: constant_part variable_part BEGIN_BLOCK optional_statements END_BLOCK
{
$$ = new elna::boot::block(elna::boot::make_position(@3));
std::swap($$->constants, $1);
std::swap($$->variables, $2);
std::swap($$->body, $4);
}
identifier_definition:
IDENTIFIER MULTIPLICATION
{
$$ = std::make_pair($1, true);
}
| IDENTIFIER
{
$$ = std::make_pair($1, false);
}
identifier_definitions:
identifier_definition COMMA identifier_definitions
{
std::swap($$, $3);
$$.emplace($$.cbegin(), $1);
}
| identifier_definition { $$.emplace_back(std::move($1)); }
procedure_heading:
PROCEDURE identifier_definition formal_parameter_list SEMICOLON
{
$$ = new elna::boot::procedure_definition(elna::boot::make_position(@1),
$2.first, $2.second);
std::swap($3, $$->parameters);
}
| PROCEDURE identifier_definition formal_parameter_list ARROW EXCLAMATION SEMICOLON
{
$$ = new elna::boot::procedure_definition(elna::boot::make_position(@1),
$2.first, $2.second, elna::boot::procedure_definition::no_return_t{});
std::swap($3, $$->parameters);
}
| PROCEDURE identifier_definition formal_parameter_list ARROW type_expression SEMICOLON
{
$$ = new elna::boot::procedure_definition(elna::boot::make_position(@1),
$2.first, $2.second, $5);
std::swap($3, $$->parameters);
}
procedure_definition:
procedure_heading block { $$ = $1->add_body($2); }
| procedure_heading EXTERN { $$ = $1; }
procedure_definitions:
procedure_definition procedure_definitions
{
std::swap($$, $2);
$$.emplace($$.cbegin(), std::move($1));
}
| procedure_definition { $$.emplace_back(std::move($1)); }
procedure_part:
/* no procedure definitions */ {}
| procedure_definitions { std::swap($$, $1); }
assign_statement: designator_expression ASSIGNMENT expression
{
$$ = new elna::boot::assign_statement(elna::boot::make_position(@1), $1, $3);
}
call_expression: IDENTIFIER actual_parameter_list
{
$$ = new elna::boot::call_expression(elna::boot::make_position(@1), $1);
std::swap($$->arguments(), $2);
}
cast_expression: CAST LEFT_PAREN expression COLON type_expression RIGHT_PAREN
{
$$ = new elna::boot::cast_expression(elna::boot::make_position(@1), $5, $3);
}
elsif_do_statements:
ELSIF expression DO optional_statements elsif_do_statements
{
elna::boot::conditional_statements *branch = new elna::boot::conditional_statements($2);
std::swap(branch->statements, $4);
std::swap($5, $$);
$$.emplace($$.begin(), branch);
}
| {}
while_statement: WHILE expression DO optional_statements elsif_do_statements END_BLOCK
{
auto body = new elna::boot::conditional_statements($2);
std::swap($4, body->statements);
$$ = new elna::boot::while_statement(elna::boot::make_position(@1), body);
std::swap($5, $$->branches);
}
elsif_then_statements:
ELSIF expression THEN optional_statements elsif_then_statements
{
elna::boot::conditional_statements *branch = new elna::boot::conditional_statements($2);
std::swap(branch->statements, $4);
std::swap($5, $$);
$$.emplace($$.begin(), branch);
}
| {}
if_statement:
IF expression THEN optional_statements elsif_then_statements END_BLOCK
{
auto then = new elna::boot::conditional_statements($2);
std::swap($4, then->statements);
$$ = new elna::boot::if_statement(elna::boot::make_position(@1), then);
std::swap($5, $$->branches);
}
| IF expression THEN optional_statements elsif_then_statements ELSE optional_statements END_BLOCK
{
auto then = new elna::boot::conditional_statements($2);
std::swap($4, then->statements);
auto _else = new std::vector<elna::boot::statement *>(std::move($7));
$$ = new elna::boot::if_statement(elna::boot::make_position(@1), then, _else);
std::swap($5, $$->branches);
}
return_statement: RETURN expression
{
$$ = new elna::boot::return_statement(elna::boot::make_position(@1), $2);
}
defer_statement: DEFER optional_statements END_BLOCK
{
$$ = new elna::boot::defer_statement(elna::boot::make_position(@1));
std::swap($2, $$->statements);
}
literal:
INTEGER
{
$$ = new elna::boot::number_literal<std::int32_t>(elna::boot::make_position(@1), $1);
}
| WORD
{
$$ = new elna::boot::number_literal<std::uint32_t>(elna::boot::make_position(@1), $1);
}
| FLOAT
{
$$ = new elna::boot::number_literal<double>(elna::boot::make_position(@1), $1);
}
| BOOLEAN
{
$$ = new elna::boot::number_literal<bool>(elna::boot::make_position(@1), $1);
}
| CHARACTER
{
$$ = new elna::boot::number_literal<unsigned char>(elna::boot::make_position(@1), $1.at(0));
}
| NIL
{
$$ = new elna::boot::number_literal<std::nullptr_t>(elna::boot::make_position(@1), nullptr);
}
| STRING
{
$$ = new elna::boot::number_literal<std::string>(elna::boot::make_position(@1), $1);
}
operand:
literal { $$ = $1; }
| designator_expression { $$ = $1; }
| LEFT_PAREN type_expression RIGHT_PAREN
{
$$ = new elna::boot::type_expression(elna::boot::make_position(@1), $2);
}
| cast_expression { $$ = $1; }
| call_expression { $$ = $1; }
| LEFT_PAREN expression RIGHT_PAREN { $$ = $2; }
expression:
unary { $$ = $1; }
| expression MULTIPLICATION expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::multiplication);
}
| expression DIVISION expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::division);
}
| expression REMAINDER expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::remainder);
}
| expression PLUS expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::sum);
}
| expression MINUS expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::subtraction);
}
| expression EQUALS expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::equals);
}
| expression NOT_EQUAL expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::not_equals);
}
| expression LESS_THAN expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::less);
}
| expression GREATER_THAN expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::greater);
}
| expression LESS_EQUAL expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::less_equal);
}
| expression GREATER_EQUAL expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::greater_equal);
}
| expression AND expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::conjunction);
}
| expression OR expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::disjunction);
}
| expression XOR expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::exclusive_disjunction);
}
| expression SHIFT_LEFT expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::shift_left);
}
| expression SHIFT_RIGHT expression
{
$$ = new elna::boot::binary_expression(elna::boot::make_position(@2), $1, $3,
elna::boot::binary_operator::shift_right);
}
unary:
AT operand
{
$$ = new elna::boot::unary_expression(elna::boot::make_position(@1), $2,
elna::boot::unary_operator::reference);
}
| NOT operand
{
$$ = new elna::boot::unary_expression(elna::boot::make_position(@1), $2,
elna::boot::unary_operator::negation);
}
| MINUS operand
{
$$ = new elna::boot::unary_expression(elna::boot::make_position(@1), $2,
elna::boot::unary_operator::minus);
}
| operand { $$ = $1; }
expressions:
expression COMMA expressions
{
std::swap($$, $3);
$$.emplace($$.cbegin(), $1);
}
| expression { $$.emplace_back(std::move($1)); }
designator_expression:
operand LEFT_SQUARE expression RIGHT_SQUARE
{
$$ = new elna::boot::array_access_expression(elna::boot::make_position(@2), $1, $3);
}
| operand DOT IDENTIFIER
{
$$ = new elna::boot::field_access_expression(elna::boot::make_position(@2), $1, $3);
}
| operand HAT
{
$$ = new elna::boot::dereference_expression(elna::boot::make_position(@1), $1);
}
| IDENTIFIER
{
$$ = new elna::boot::variable_expression(elna::boot::make_position(@1), $1);
}
statement:
assign_statement { $$ = $1; }
| while_statement { $$ = $1; }
| if_statement { $$ = $1; }
| return_statement { $$ = $1; }
| call_expression
{
$$ = new elna::boot::call_statement(elna::boot::make_position(@1), $1);
}
| defer_statement { $$ = $1; }
statements:
statement statements
{
std::swap($$, $2);
$$.emplace($$.cbegin(), $1);
}
| statement { $$.push_back($1); }
optional_statements:
statements { std::swap($$, $1); }
| /* no statements */ {}
field_declaration:
IDENTIFIER COLON type_expression { $$ = std::make_pair($1, $3); }
fields:
field_declaration fields
{
std::swap($$, $2);
$$.emplace($$.cbegin(), $1);
}
| field_declaration { $$.emplace_back($1); }
optional_fields:
fields { std::swap($$, $1); }
| /* no fields */ {}
type_expression:
LEFT_SQUARE INTEGER RIGHT_SQUARE type_expression
{
$$ = std::make_shared<elna::boot::array_type>(elna::boot::make_position(@1), $4, $2);
}
| HAT type_expression
{
$$ = std::make_shared<elna::boot::pointer_type>(elna::boot::make_position(@1), $2);
}
| RECORD optional_fields END_BLOCK
{
$$ = std::make_shared<elna::boot::record_type>(elna::boot::make_position(@1), std::move($2));
}
| UNION fields END_BLOCK
{
$$ = std::make_shared<elna::boot::union_type>(elna::boot::make_position(@1), std::move($2));
}
| IDENTIFIER
{
$$ = std::make_shared<elna::boot::basic_type>(elna::boot::make_position(@1), $1);
}
variable_declaration: identifier_definitions COLON type_expression
{
for (const std::pair<std::string, bool>& identifier : $1)
{
elna::boot::variable_declaration *declaration = new elna::boot::variable_declaration(
elna::boot::make_position(@2), identifier.first, $3, identifier.second);
$$.push_back(declaration);
}
}
variable_declarations:
variable_declaration variable_declarations
{
std::swap($$, $1);
$$.reserve($$.size() + $2.size());
$$.insert(std::end($$), std::begin($2), std::end($2));
}
| variable_declaration { std::swap($$, $1); }
variable_part:
/* no variable declarations */ {}
| VAR variable_declarations { std::swap($$, $2); }
constant_definition: identifier_definition EQUALS literal
{
$$ = new elna::boot::constant_definition(elna::boot::make_position(@1), $1.first, $1.second, $3);
}
constant_definitions:
constant_definition constant_definitions
{
std::swap($$, $2);
$$.emplace($$.cbegin(), std::move($1));
}
| constant_definition { $$.emplace_back(std::move($1)); }
constant_part:
/* no constant definitions */ {}
| CONST {}
| CONST constant_definitions { std::swap($$, $2); }
type_definition: identifier_definition EQUALS type_expression
{
$$ = new elna::boot::type_definition(elna::boot::make_position(@1), $1.first, $1.second, $3);
}
type_definitions:
type_definition type_definitions
{
std::swap($$, $2);
$$.emplace($$.cbegin(), std::move($1));
}
| type_definition { $$.emplace_back(std::move($1)); }
type_part:
/* no type definitions */ {}
| TYPE {}
| TYPE type_definitions { std::swap($$, $2); }
formal_parameter: IDENTIFIER COLON type_expression
{
$$ = new elna::boot::variable_declaration(elna::boot::make_position(@2), $1, $3);
}
formal_parameters:
formal_parameter COMMA formal_parameters
{
std::swap($$, $3);
$$.emplace($$.cbegin(), $1);
}
| formal_parameter { $$.emplace_back(std::move($1)); }
formal_parameter_list:
LEFT_PAREN RIGHT_PAREN {}
| LEFT_PAREN formal_parameters RIGHT_PAREN { std::swap($$, $2); }
actual_parameter_list:
LEFT_PAREN RIGHT_PAREN {}
| LEFT_PAREN expressions RIGHT_PAREN { std::swap($$, $2); }
%%
void yy::parser::error(const location_type& loc, const std::string& message)
{
driver.error(loc, message);
}

39
boot/result.cc
View File

@ -1,39 +0,0 @@
/* Miscellaneous types used across stage boundaries.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "elna/boot/result.h"
namespace elna
{
namespace boot
{
error::error(const char *path, const struct position position)
: position(position), path(path)
{
}
std::size_t error::line() const noexcept
{
return this->position.line;
}
std::size_t error::column() const noexcept
{
return this->position.column;
}
}
}

21
config-lang.in
View File

@ -1,21 +0,0 @@
# Top level configure fragment for gcc Elna frontend.
# Copyright (C) 2025 Free Software Foundation, Inc.
# GCC is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3, or (at your option)
# any later version.
# GCC is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with GCC; see the file COPYING3. If not see
# <http://www.gnu.org/licenses/>.
language="elna"
gcc_subdir="elna/gcc"
. ${srcdir}/elna/gcc/config-lang.in

88
elna.cabal Normal file
View File

@ -0,0 +1,88 @@
cabal-version: 3.4
name: elna
version: 0.1.0.0
synopsis:
Elna programming language compiles simple mathematical operations to RISC-V code
license: MPL-2.0
license-file: LICENSE
author: Eugen Wissner
maintainer: belka@caraus.de
category: Language
build-type: Simple
extra-doc-files: TODO README
common warnings
build-depends:
base >=4.7 && <5,
bytestring ^>= 0.12.1,
filepath ^>= 1.5.3,
megaparsec ^>= 9.6,
optparse-applicative ^>= 0.18.1,
vector ^>= 0.13.1,
text ^>= 2.0
ghc-options: -Wall
default-extensions:
DataKinds,
ExplicitForAll,
LambdaCase,
OverloadedStrings,
DuplicateRecordFields,
RecordWildCards
default-language: GHC2021
library elna-internal
import: warnings
exposed-modules:
Language.Elna.Architecture.RiscV
Language.Elna.Backend.Allocator
Language.Elna.Backend.Intermediate
Language.Elna.Driver
Language.Elna.Driver.CommandLine
Language.Elna.Frontend.AST
Language.Elna.Frontend.NameAnalysis
Language.Elna.Frontend.Parser
Language.Elna.Frontend.SymbolTable
Language.Elna.Frontend.TypeAnalysis
Language.Elna.Frontend.Types
Language.Elna.Glue
Language.Elna.Location
Language.Elna.Object.Elf
Language.Elna.Object.ElfCoder
Language.Elna.Object.StringTable
Language.Elna.RiscV.CodeGenerator
Language.Elna.RiscV.ElfWriter
build-depends:
exceptions ^>= 0.10,
hashable ^>= 1.4.3,
parser-combinators ^>= 1.3,
transformers ^>= 0.6.1,
unordered-containers ^>= 0.2.20
hs-source-dirs: lib
executable elna
import: warnings
main-is: Main.hs
build-depends:
elna:elna-internal
hs-source-dirs: src
test-suite elna-test
import: warnings
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Language.Elna.NameAnalysisSpec
Language.Elna.ParserSpec
hs-source-dirs:
tests
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
build-depends:
elna:elna-internal,
hspec >= 2.10.9 && < 2.12,
hspec-expectations ^>= 0.8.2,
hspec-megaparsec ^>= 2.2.0,
text
build-tool-depends:
hspec-discover:hspec-discover

130
gcc/Make-lang.in
View File

@ -1,130 +0,0 @@
# Top level -*- makefile -*- fragment for the Elna frontend.
# Copyright (C) 2025 Free Software Foundation, Inc.
# GCC is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3, or (at your option)
# any later version.
# GCC is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with GCC; see the file COPYING3. If not see
# <http://www.gnu.org/licenses/>.
ELNA_INSTALL_NAME := $(shell echo gelna|sed '$(program_transform_name)')
ELNA_TARGET_INSTALL_NAME := $(target_noncanonical)-$(shell echo gelna|sed '$(program_transform_name)')
elna: elna1$(exeext)
.PHONY: elna
# Driver
ELNA_OBJS = \
$(GCC_OBJS) \
elna/elna-spec.o \
$(END)
gelna$(exeext): $(ELNA_OBJS) $(EXTRA_GCC_OBJS) libcommon-target.a $(LIBDEPS)
+$(LINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) -o $@ \
$(ELNA_OBJS) $(EXTRA_GCC_OBJS) libcommon-target.a \
$(EXTRA_GCC_LIBS) $(LIBS)
# The compiler proper
elna_OBJS = \
elna/elna1.o \
elna/elna-generic.o \
elna/elna-diagnostic.o \
elna/elna-tree.o \
elna/elna-builtins.o \
elna/ast.o \
elna/driver.o \
elna/lexer.o \
elna/parser.o \
elna/result.o \
$(END)
elna1$(exeext): attribs.o $(elna_OBJS) $(BACKEND) $(LIBDEPS)
+$(LLINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) -o $@ \
attribs.o $(elna_OBJS) $(BACKEND) $(LIBS) $(BACKENDLIBS)
elna.all.cross:
elna.start.encap: gelna$(exeext)
elna.rest.encap:
# No elna-specific selftests.
selftest-elna:
elna.install-common: installdirs
-rm -f $(DESTDIR)$(bindir)/$(ELNA_INSTALL_NAME)$(exeext)
$(INSTALL_PROGRAM) gelna$(exeext) $(DESTDIR)$(bindir)/$(ELNA_INSTALL_NAME)$(exeext)
rm -f $(DESTDIR)$(bindir)/$(ELNA_TARGET_INSTALL_NAME)$(exeext); \
( cd $(DESTDIR)$(bindir) && \
$(LN) $(ELNA_INSTALL_NAME)$(exeext) $(ELNA_TARGET_INSTALL_NAME)$(exeext) ); \
# Required goals, they still do nothing
elna.install-man:
elna.install-info:
elna.install-pdf:
elna.install-plugin:
elna.install-html:
elna.info:
elna.dvi:
elna.pdf:
elna.html:
elna.man:
elna.mostlyclean:
elna.clean:
elna.distclean:
elna.maintainer-clean:
# make uninstall
elna.uninstall:
-rm -f gelna$(exeext) elna1$(exeext)
-rm -f $(elna_OBJS)
# Used for handling bootstrap
elna.stage1: stage1-start
-mv elna/*$(objext) stage1/elna
elna.stage2: stage2-start
-mv elna/*$(objext) stage2/elna
elna.stage3: stage3-start
-mv elna/*$(objext) stage3/elna
elna.stage4: stage4-start
-mv elna/*$(objext) stage4/elna
elna.stageprofile: stageprofile-start
-mv elna/*$(objext) stageprofile/elna
elna.stagefeedback: stagefeedback-start
-mv elna/*$(objext) stagefeedback/elna
ELNA_INCLUDES = -I $(srcdir)/elna/include -I elna/generated
ELNA_CXXFLAGS = -std=c++11
elna/%.o: elna/boot/%.cc elna/generated/parser.hh elna/generated/location.hh
$(COMPILE) $(ELNA_CXXFLAGS) $(ELNA_INCLUDES) $<
$(POSTCOMPILE)
elna/%.o: elna/generated/%.cc elna/generated/parser.hh elna/generated/location.hh
$(COMPILE) $(ELNA_CXXFLAGS) $(ELNA_INCLUDES) $<
$(POSTCOMPILE)
elna/%.o: elna/gcc/%.cc elna/generated/parser.hh elna/generated/location.hh
$(COMPILE) $(ELNA_CXXFLAGS) $(ELNA_INCLUDES) $<
$(POSTCOMPILE)
elna/generated/parser.cc: elna/boot/parser.yy
mkdir -p $(dir $@)
$(BISON) -d -o $@ $<
elna/generated/parser.hh elna/generated/location.hh: elna/generated/parser.cc
@touch $@
elna/generated/lexer.cc: elna/boot/lexer.ll
mkdir -p $(dir $@)
$(FLEX) -o $@ $<

37
gcc/config-lang.in
View File

@ -1,37 +0,0 @@
# Top level configure fragment for gcc Elna frontend.
# Copyright (C) 2025 Free Software Foundation, Inc.
# GCC is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3, or (at your option)
# any later version.
# GCC is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with GCC; see the file COPYING3. If not see
# <http://www.gnu.org/licenses/>.
# Configure looks for the existence of this file to auto-config each language.
# We define several parameters used by configure:
#
# language - name of language as it would appear in $(LANGUAGES)
# boot_language - "yes" if we need to build this language in stage1
# compilers - value to add to $(COMPILERS)
language="elna"
gcc_subdir="elna/gcc"
compilers="elna1\$(exeext)"
target_libs=""
gtfiles="\$(srcdir)/elna/gcc/elna1.cc \$(srcdir)/elna/include/elna/gcc/elna1.h"
lang_requires_boot_languages=c++
# Do not build by default
build_by_default="no"

54
gcc/elna-builtins.cc
View File

@ -1,54 +0,0 @@
/* Builtin definitions.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "elna/gcc/elna-builtins.h"
#include "elna/gcc/elna1.h"
#include "stor-layout.h"
#include "stringpool.h"
#include "elna/gcc/elna-tree.h"
namespace elna
{
namespace gcc
{
void init_ttree()
{
elna_int_type_node = long_integer_type_node;
elna_word_type_node = size_type_node;
elna_char_type_node = unsigned_char_type_node;
elna_byte_type_node = make_unsigned_type(8);
elna_float_type_node = double_type_node;
elna_bool_type_node = boolean_type_node;
elna_bool_true_node = boolean_true_node;
elna_bool_false_node = boolean_false_node;
elna_pointer_nil_node = null_pointer_node;
elna_string_type_node = make_node(RECORD_TYPE);
tree string_ptr_type = build_pointer_type_for_mode(elna_char_type_node, VOIDmode, true);
elna_string_length_field_node = build_field(UNKNOWN_LOCATION,
elna_string_type_node, "length", build_qualified_type(elna_word_type_node, TYPE_QUAL_CONST));
elna_string_ptr_field_node = build_field(UNKNOWN_LOCATION,
elna_string_type_node, "ptr", build_qualified_type(string_ptr_type, TYPE_QUAL_CONST));
TYPE_FIELDS(elna_string_type_node) = chainon(elna_string_ptr_field_node, elna_string_length_field_node);
layout_type(elna_string_type_node);
}
}
}

128
gcc/elna-diagnostic.cc
View File

@ -1,128 +0,0 @@
/* Elna frontend specific diagnostic routines.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "elna/gcc/elna-diagnostic.h"
#include "elna/gcc/elna-tree.h"
#include "elna/gcc/elna1.h"
namespace elna
{
namespace gcc
{
location_t get_location(const boot::position *position)
{
linemap_line_start(line_table, position->line, 0);
return linemap_position_for_column(line_table, position->column);
}
std::string print_aggregate_name(tree type, const std::string& kind_name)
{
if (TYPE_IDENTIFIER(type) == NULL_TREE)
{
return kind_name;
}
else
{
return std::string(IDENTIFIER_POINTER(TYPE_IDENTIFIER(type)));
}
}
std::string print_type(tree type)
{
gcc_assert(TYPE_P(type));
if (type == elna_int_type_node)
{
return "Int";
}
else if (type == elna_word_type_node)
{
return "Word";
}
else if (type == elna_bool_type_node)
{
return "Bool";
}
else if (type == elna_byte_type_node)
{
return "Byte";
}
else if (type == elna_float_type_node)
{
return "Float";
}
else if (type == elna_char_type_node)
{
return "Char";
}
else if (type == elna_string_type_node)
{
return "String";
}
else if (is_void_type(type)) // For procedures without a return type.
{
return "()";
}
else if (is_pointer_type(type))
{
return std::string("^" + print_type(TREE_TYPE(type)));
}
else if (is_procedure_type(type))
{
std::string output = "proc(";
tree parameter_type = TYPE_ARG_TYPES(type);
while (parameter_type != NULL_TREE)
{
output += print_type(TREE_VALUE(parameter_type));
parameter_type = TREE_CHAIN(parameter_type);
if (TREE_VALUE(parameter_type) == void_type_node)
{
break;
}
else
{
output += ", ";
}
}
output += ')';
if (!is_void_type(TREE_TYPE(type)))
{
output += " -> " + print_type(TREE_TYPE(type));
}
return output;
}
else if (is_array_type(type))
{
return "array";
}
else if (TREE_CODE(type) == RECORD_TYPE)
{
return print_aggregate_name(type, "record");
}
else if (TREE_CODE(type) == UNION_TYPE)
{
return print_aggregate_name(type, "union");
}
else
{
return "<<unknown-type>>";
}
gcc_unreachable();
}
}
}

1172
gcc/elna-generic.cc
View File

File diff suppressed because it is too large Load Diff

31
gcc/elna-spec.cc
View File

@ -1,31 +0,0 @@
/* Specific flags and argument handling of the Elna front end.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
void lang_specific_driver(struct cl_decoded_option ** /* in_decoded_options */,
unsigned int * /* in_decoded_options_count */,
int * /*in_added_libraries */)
{
}
/* Called before linking. Returns 0 on success and -1 on failure. */
int lang_specific_pre_link (void)
{
return 0;
}
/* Number of extra output files that lang_specific_pre_link may generate. */
int lang_specific_extra_outfiles = 0;

207
gcc/elna-tree.cc
View File

@ -1,207 +0,0 @@
/* Utilities to manipulate GCC trees.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "elna/gcc/elna-tree.h"
#include "elna/gcc/elna-diagnostic.h"
#include "elna/gcc/elna1.h"
#include "function.h"
#include "stor-layout.h"
#include "fold-const.h"
#include "diagnostic-core.h"
namespace elna
{
namespace gcc
{
bool is_pointer_type(tree type)
{
gcc_assert(TYPE_P(type));
return TREE_CODE(type) == POINTER_TYPE;
}
bool is_integral_type(tree type)
{
gcc_assert(TYPE_P(type));
return TREE_CODE(type) == INTEGER_TYPE;
}
bool is_numeric_type(tree type)
{
return is_integral_type(type) || type == elna_float_type_node;
}
bool is_array_type(tree type)
{
gcc_assert(TYPE_P(type));
return TREE_CODE(type) == ARRAY_TYPE;
}
bool is_procedure_type(tree type)
{
gcc_assert(TYPE_P(type));
return TREE_CODE(type) == FUNCTION_TYPE;
}
bool is_void_type(tree type)
{
return type == NULL_TREE || type == void_type_node;
}
bool is_aggregate_type(tree type)
{
gcc_assert(TYPE_P(type));
return TREE_CODE(type) == RECORD_TYPE || TREE_CODE(type) == UNION_TYPE;
}
bool are_compatible_pointers(tree lhs_type, tree rhs)
{
gcc_assert(TYPE_P(lhs_type));
tree rhs_type = TREE_TYPE(rhs);
return (is_pointer_type(lhs_type) && rhs == elna_pointer_nil_node)
|| (is_pointer_type(lhs_type) && lhs_type == rhs_type);
}
bool is_assignable_from(tree assignee, tree assignment)
{
return get_qualified_type(TREE_TYPE(assignment), TYPE_UNQUALIFIED) == assignee
|| are_compatible_pointers(assignee, assignment);
}
void append_statement(tree statement_tree)
{
if (!vec_safe_is_empty(f_binding_level->defers))
{
append_to_statement_list(statement_tree, &f_binding_level->defers->begin()->try_statements);
}
else
{
append_to_statement_list(statement_tree, &f_binding_level->statement_list);
}
}
void defer(tree statement_tree)
{
defer_scope new_defer{ statement_tree, alloc_stmt_list() };
vec_safe_insert(f_binding_level->defers, 0, new_defer);
}
tree chain_defer()
{
if (vec_safe_is_empty(f_binding_level->defers))
{
return f_binding_level->statement_list;
}
defer_scope *defer_iterator = f_binding_level->defers->begin();
tree defer_tree = build2(TRY_FINALLY_EXPR, void_type_node,
defer_iterator->try_statements, defer_iterator->defer_block);
int i;
FOR_EACH_VEC_ELT_FROM(*f_binding_level->defers, i, defer_iterator, 1)
{
append_to_statement_list(defer_tree, &defer_iterator->try_statements);
defer_tree = build2(TRY_FINALLY_EXPR, void_type_node,
defer_iterator->try_statements, defer_iterator->defer_block);
}
return build2(COMPOUND_EXPR, TREE_TYPE(defer_tree), f_binding_level->statement_list, defer_tree);
}
tree build_field(location_t location, tree record_type, const std::string name, tree type)
{
tree field_declaration = build_decl(location,
FIELD_DECL, get_identifier(name.c_str()), type);
TREE_ADDRESSABLE(field_declaration) = 1;
DECL_CONTEXT(field_declaration) = record_type;
return field_declaration;
}
tree do_pointer_arithmetic(boot::binary_operator binary_operator, tree left, tree right)
{
tree left_type = get_qualified_type(TREE_TYPE(left), TYPE_UNQUALIFIED);
tree right_type = get_qualified_type(TREE_TYPE(right), TYPE_UNQUALIFIED);
if (binary_operator == boot::binary_operator::sum)
{
tree pointer{ NULL_TREE };
tree offset{ NULL_TREE };
if (is_pointer_type(left_type) && is_integral_type(right_type))
{
pointer = left;
offset = right;
}
else if (is_integral_type(left_type) && is_pointer_type(right_type))
{
pointer = right;
offset = left;
}
else
{
return error_mark_node;
}
tree size_exp = fold_convert(TREE_TYPE(offset), size_in_bytes(TREE_TYPE(TREE_TYPE(pointer))));
offset = fold_build2(MULT_EXPR, TREE_TYPE(offset), offset, size_exp);
offset = fold_convert(sizetype, offset);
return fold_build2(POINTER_PLUS_EXPR, TREE_TYPE(pointer), pointer, offset);
}
else if (binary_operator == boot::binary_operator::subtraction)
{
if (is_pointer_type(left_type) && is_integral_type(right_type))
{
tree pointer_type = left_type;
tree offset_type = right_type;
tree size_exp = fold_convert(offset_type, size_in_bytes(TREE_TYPE(pointer_type)));
tree convert_expression = fold_build2(MULT_EXPR, offset_type, right, size_exp);
convert_expression = fold_convert(sizetype, convert_expression);
convert_expression = fold_build1(NEGATE_EXPR, sizetype, convert_expression);
return fold_build2(POINTER_PLUS_EXPR, pointer_type, left, convert_expression);
}
else if (is_pointer_type(left_type) && is_pointer_type(right_type) && left_type == right_type)
{
return fold_build2(POINTER_DIFF_EXPR, ssizetype, left, right);
}
}
gcc_unreachable();
}
tree build_binary_operation(bool condition, boot::binary_expression *expression,
tree_code operator_code, tree left, tree right, tree target_type)
{
location_t expression_location = get_location(&expression->position());
tree left_type = get_qualified_type(TREE_TYPE(left), TYPE_UNQUALIFIED);
tree right_type = get_qualified_type(TREE_TYPE(right), TYPE_UNQUALIFIED);
if (condition)
{
return build2_loc(expression_location, operator_code, target_type, left, right);
}
else
{
error_at(expression_location,
"invalid operands of type '%s' and '%s' for operator %s",
print_type(left_type).c_str(), print_type(right_type).c_str(),
elna::boot::print_binary_operator(expression->operation()));
return error_mark_node;
}
}
}
}

228
gcc/elna1.cc
View File

@ -1,228 +0,0 @@
/* Language-dependent hooks for Elna.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "target.h"
#include "function.h"
#include "tree.h"
#include "elna/gcc/elna1.h"
#include "diagnostic.h"
#include "opts.h"
#include "debug.h"
#include "langhooks.h"
#include "langhooks-def.h"
#include <fstream>
#include "elna/boot/driver.h"
#include "elna/gcc/elna-tree.h"
#include "elna/gcc/elna-generic.h"
#include "elna/gcc/elna-diagnostic.h"
#include "elna/gcc/elna-builtins.h"
#include "parser.hh"
tree elna_global_trees[ELNA_TI_MAX];
hash_map<nofree_string_hash, tree> *elna_global_decls = nullptr;
/* The resulting tree type. */
union GTY ((desc("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
chain_next("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), "
"TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN "
"(&%h.generic)) : NULL"))) lang_tree_node
{
union tree_node GTY ((tag ("0"), desc ("tree_node_structure (&%h)"))) generic;
};
/* Language hooks. */
static bool elna_langhook_init(void)
{
build_common_tree_nodes(false);
elna::gcc::init_ttree();
elna_global_decls = hash_map<nofree_string_hash, tree>::create_ggc(default_hash_map_size);
build_common_builtin_nodes();
return true;
}
static void elna_parse_file(const char *filename)
{
std::ifstream file{ filename, std::ios::in };
if (!file)
{
fatal_error(UNKNOWN_LOCATION, "cannot open filename %s: %m", filename);
}
elna::boot::driver driver{ filename };
elna::boot::lexer lexer(file);
yy::parser parser(lexer, driver);
linemap_add(line_table, LC_ENTER, 0, filename, 1);
if (parser())
{
for (const auto& error : driver.errors())
{
auto gcc_location = elna::gcc::get_location(&error->position);
error_at(gcc_location, error->what().c_str());
}
}
else
{
elna::gcc::generic_visitor generic_visitor{ std::make_shared<elna::gcc::symbol_table>() };
generic_visitor.visit(driver.tree.get());
}
linemap_add(line_table, LC_LEAVE, 0, NULL, 0);
}
static void elna_langhook_parse_file(void)
{
for (unsigned int i = 0; i < num_in_fnames; i++)
{
elna_parse_file(in_fnames[i]);
}
}
static tree elna_langhook_type_for_mode(enum machine_mode mode, int unsignedp)
{
if (mode == TYPE_MODE(float_type_node))
{
return float_type_node;
}
else if (mode == TYPE_MODE(double_type_node))
{
return double_type_node;
}
if (mode == TYPE_MODE(intQI_type_node))
{
return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
}
else if (mode == TYPE_MODE(intHI_type_node))
{
return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
}
else if (mode == TYPE_MODE(intSI_type_node))
{
return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
}
else if (mode == TYPE_MODE(intDI_type_node))
{
return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
}
else if (mode == TYPE_MODE(intTI_type_node))
{
return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
}
else if (mode == TYPE_MODE(integer_type_node))
{
return unsignedp ? unsigned_type_node : integer_type_node;
}
else if (mode == TYPE_MODE(long_integer_type_node))
{
return unsignedp ? long_unsigned_type_node : long_integer_type_node;
}
else if (mode == TYPE_MODE(long_long_integer_type_node))
{
return unsignedp
? long_long_unsigned_type_node
: long_long_integer_type_node;
}
if (COMPLEX_MODE_P(mode))
{
if (mode == TYPE_MODE(complex_float_type_node))
{
return complex_float_type_node;
}
if (mode == TYPE_MODE(complex_double_type_node))
{
return complex_double_type_node;
}
if (mode == TYPE_MODE(complex_long_double_type_node))
{
return complex_long_double_type_node;
}
if (mode == TYPE_MODE(complex_integer_type_node) && !unsignedp)
{
return complex_integer_type_node;
}
}
/* gcc_unreachable */
return nullptr;
}
static bool global_bindings_p(void)
{
return current_function_decl == NULL_TREE;
}
static tree pushdecl(tree decl)
{
return decl;
}
static tree elna_langhook_builtin_function(tree decl)
{
elna_global_decls->put(IDENTIFIER_POINTER(DECL_NAME(decl)), decl);
return decl;
}
/* Creates an expression whose value is that of EXPR, converted to type TYPE.
This function implements all reasonable scalar conversions. */
tree convert(tree type, tree expr)
{
if (error_operand_p(type) || error_operand_p(expr))
{
return error_mark_node;
}
if (TREE_TYPE(expr) == type)
{
return expr;
}
return error_mark_node;
}
#undef LANG_HOOKS_NAME
#define LANG_HOOKS_NAME "GNU Elna"
#undef LANG_HOOKS_INIT
#define LANG_HOOKS_INIT elna_langhook_init
#undef LANG_HOOKS_PARSE_FILE
#define LANG_HOOKS_PARSE_FILE elna_langhook_parse_file
#undef LANG_HOOKS_TYPE_FOR_MODE
#define LANG_HOOKS_TYPE_FOR_MODE elna_langhook_type_for_mode
#undef LANG_HOOKS_GETDECLS
#define LANG_HOOKS_GETDECLS hook_tree_void_null
#undef LANG_HOOKS_BUILTIN_FUNCTION
#define LANG_HOOKS_BUILTIN_FUNCTION elna_langhook_builtin_function
#undef LANG_HOOKS_IDENTIFIER_SIZE
#define LANG_HOOKS_IDENTIFIER_SIZE sizeof(struct tree_identifier)
struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
#include "gt-elna-elna1.h"
#include "gtype-elna.h"

26
gcc/lang-specs.h
View File

@ -1,26 +0,0 @@
/* GCC driver specs for Elna frontend.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
/* gcc/gcc.cc */
{".elna", "@elna", nullptr, 0, 0},
{"@elna",
"elna1 %i \
%{!Q:-quiet} \
%{!fsyntax-only:%{S:%W{o*}%{!o*:-o %w%b.s}}} \
%{fsyntax-only:-o %j} %{-param*} \
%{!fsyntax-only:%(invoke_as)}",
nullptr, 0, 0},

724
include/elna/boot/ast.h
View File

@ -1,724 +0,0 @@
/* Abstract syntax tree representation.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#pragma once
#include <cstdint>
#include <memory>
#include <string>
#include <vector>
#include "elna/boot/result.h"
namespace elna
{
namespace boot
{
enum class binary_operator
{
sum,
subtraction,
multiplication,
division,
remainder,
equals,
not_equals,
less,
greater,
less_equal,
greater_equal,
disjunction,
conjunction,
exclusive_disjunction,
shift_left,
shift_right
};
enum class unary_operator
{
reference,
negation,
minus
};
class variable_declaration;
class constant_definition;
class procedure_definition;
class type_definition;
class call_expression;
class cast_expression;
class type_expression;
class assign_statement;
class if_statement;
class while_statement;
class return_statement;
class call_statement;
class block;
class program;
class binary_expression;
class unary_expression;
class basic_type;
class array_type;
class pointer_type;
class record_type;
class union_type;
class variable_expression;
class array_access_expression;
class field_access_expression;
class dereference_expression;
template<typename T>
class number_literal;
class defer_statement;
/**
* Interface for AST visitors.
*/
struct parser_visitor
{
virtual void visit(variable_declaration *) = 0;
virtual void visit(constant_definition *) = 0;
virtual void visit(procedure_definition *) = 0;
virtual void visit(type_definition *) = 0;
virtual void visit(call_expression *) = 0;
virtual void visit(cast_expression *) = 0;
virtual void visit(type_expression *) = 0;
virtual void visit(call_statement *) = 0;
virtual void visit(assign_statement *) = 0;
virtual void visit(if_statement *) = 0;
virtual void visit(while_statement *) = 0;
virtual void visit(return_statement *) = 0;
virtual void visit(defer_statement *) = 0;
virtual void visit(block *) = 0;
virtual void visit(program *) = 0;
virtual void visit(binary_expression *) = 0;
virtual void visit(unary_expression *) = 0;
virtual void visit(basic_type *) = 0;
virtual void visit(array_type *) = 0;
virtual void visit(pointer_type *) = 0;
virtual void visit(record_type *) = 0;
virtual void visit(union_type *) = 0;
virtual void visit(variable_expression *) = 0;
virtual void visit(array_access_expression *) = 0;
virtual void visit(field_access_expression *is_field_access) = 0;
virtual void visit(dereference_expression *is_dereference) = 0;
virtual void visit(number_literal<std::int32_t> *) = 0;
virtual void visit(number_literal<std::uint32_t> *) = 0;
virtual void visit(number_literal<double> *) = 0;
virtual void visit(number_literal<bool> *) = 0;
virtual void visit(number_literal<unsigned char> *) = 0;
virtual void visit(number_literal<std::nullptr_t> *) = 0;
virtual void visit(number_literal<std::string> *) = 0;
};
/**
* A visitor which visits all nodes but does nothing.
*/
struct empty_visitor : parser_visitor
{
virtual void visit(variable_declaration *) override;
virtual void visit(constant_definition *definition) override;
virtual void visit(procedure_definition *definition) override;
virtual void visit(type_definition *definition) override;
virtual void visit(call_expression *expression) override;
virtual void visit(cast_expression *expression) override;
virtual void visit(type_expression *expression) override;
virtual void visit(call_statement *statement) override;
virtual void visit(assign_statement *statement) override;
virtual void visit(if_statement *) override;
virtual void visit(while_statement *) override;
virtual void visit(return_statement *) override;
virtual void visit(defer_statement *defer) override;
virtual void visit(block *block) override;
virtual void visit(program *program) override;
virtual void visit(binary_expression *expression) override;
virtual void visit(unary_expression *expression) override;
virtual void visit(basic_type *) override;
virtual void visit(array_type *expression) override;
virtual void visit(pointer_type *) override;
virtual void visit(record_type *expression) override;
virtual void visit(union_type *expression) override;
virtual void visit(variable_expression *) override;
virtual void visit(array_access_expression *expression) override;
virtual void visit(field_access_expression *expression) override;
virtual void visit(dereference_expression *expression) override;
virtual void visit(number_literal<std::int32_t> *) override;
virtual void visit(number_literal<std::uint32_t> *) override;
virtual void visit(number_literal<double> *) override;
virtual void visit(number_literal<bool> *) override;
virtual void visit(number_literal<unsigned char> *) override;
virtual void visit(number_literal<std::nullptr_t> *) override;
virtual void visit(number_literal<std::string> *) override;
};
/**
* AST node.
*/
class node
{
const struct position source_position;
protected:
/**
* \param position Source code position.
*/
explicit node(const position position);
public:
virtual ~node() = default;
virtual void accept(parser_visitor *) = 0;
/**
* \return Node position in the source code.
*/
const struct position& position() const;
};
class statement : public node
{
protected:
/**
* \param position Source code position.
*/
explicit statement(const struct position position);
};
class expression : public node
{
protected:
/**
* \param position Source code position.
*/
explicit expression(const struct position position);
};
/**
* Symbol definition.
*/
class definition : public node
{
protected:
definition(const struct position position, const std::string& identifier, const bool exported);
public:
const std::string identifier;
const bool exported;
};
/**
* Some type expression.
*/
class top_type : public node
{
public:
virtual basic_type *is_basic();
virtual array_type *is_array();
virtual pointer_type *is_pointer();
virtual record_type *is_record();
virtual union_type *is_union();
protected:
top_type(const struct position position);
};
/**
* Expression defining a basic type.
*/
class basic_type : public top_type
{
const std::string m_name;
public:
/**
* \param position Source code position.
* \param name Type name.
*/
basic_type(const struct position position, const std::string& name);
virtual void accept(parser_visitor *visitor) override;
const std::string& base_name();
basic_type *is_basic() override;
};
class array_type : public top_type
{
std::shared_ptr<top_type> m_base;
public:
const std::uint32_t size;
array_type(const struct position position, std::shared_ptr<top_type> base, const std::uint32_t size);
virtual void accept(parser_visitor *visitor) override;
top_type& base();
array_type *is_array() override;
};
class pointer_type : public top_type
{
std::shared_ptr<top_type> m_base;
public:
pointer_type(const struct position position, std::shared_ptr<top_type> base);
virtual void accept(parser_visitor *visitor) override;
top_type& base();
pointer_type *is_pointer() override;
};
using field_t = std::pair<std::string, std::shared_ptr<top_type>>;
using fields_t = std::vector<field_t>;
class composite_type : public top_type
{
protected:
composite_type(const struct position position, fields_t&& fields);
public:
fields_t fields;
};
class record_type : public composite_type
{
public:
record_type(const struct position position, fields_t&& fields);
virtual void accept(parser_visitor *visitor) override;
record_type *is_record() override;
};
class union_type : public composite_type
{
public:
union_type(const struct position position, fields_t&& fields);
virtual void accept(parser_visitor *visitor) override;
union_type *is_union() override;
};
/**
* Variable declaration.
*/
class variable_declaration : public definition
{
std::shared_ptr<top_type> m_type;
public:
variable_declaration(const struct position position, const std::string& identifier,
std::shared_ptr<top_type> type, const bool exported = false);
virtual void accept(parser_visitor *visitor) override;
top_type& variable_type();
};
/**
* Literal expression.
*/
class literal : public expression
{
protected:
explicit literal(const struct position position);
};
/**
* Constant definition.
*/
class constant_definition : public definition
{
literal *m_body;
public:
/**
* \param position Source code position.
* \param identifier Constant name.
* \param body Constant value.
*/
constant_definition(const struct position position, const std::string& identifier,
const bool exported, literal *body);
virtual void accept(parser_visitor *visitor) override;
literal& body();
virtual ~constant_definition() override;
};
/**
* Procedure definition.
*/
class procedure_definition : public definition
{
std::shared_ptr<top_type> m_return_type{ nullptr };
block *m_body{ nullptr };
public:
struct no_return_t
{
};
const bool no_return{ false };
std::vector<variable_declaration *> parameters;
procedure_definition(const struct position position, const std::string& identifier,
const bool exported, std::shared_ptr<top_type> return_type = nullptr);
procedure_definition(const struct position position, const std::string& identifier,
const bool exported, no_return_t);
virtual void accept(parser_visitor *visitor) override;
std::shared_ptr<top_type> return_type();
block *body();
procedure_definition *add_body(block *procedure_body);
virtual ~procedure_definition() override;
};
/**
* Type definition.
*/
class type_definition : public definition
{
std::shared_ptr<top_type> m_body;
public:
type_definition(const struct position position, const std::string& identifier,
const bool exported, std::shared_ptr<top_type> expression);
virtual void accept(parser_visitor *visitor) override;
top_type& body();
};
/**
* Procedure call expression.
*/
class call_expression : public expression
{
std::string m_name;
std::vector<expression *> m_arguments;
public:
/**
* \param position Source code position.
* \param name Callable's name.
*/
call_expression(const struct position position, const std::string& name);
virtual void accept(parser_visitor *visitor) override;
std::string& name();
std::vector<expression *>& arguments();
virtual ~call_expression() override;
};
/**
* Cast expression.
*/
class cast_expression : public expression
{
std::shared_ptr<top_type> m_target;
expression *m_value;
public:
cast_expression(const struct position position, std::shared_ptr<top_type> target, expression *value);
virtual void accept(parser_visitor *visitor) override;
top_type& target();
expression& value();
virtual ~cast_expression() override;
};
/**
* Type inside an expression.
*/
class type_expression : public expression
{
std::shared_ptr<top_type> m_body;
public:
type_expression(const struct position position, std::shared_ptr<top_type> body);
virtual void accept(parser_visitor *visitor) override;
top_type& body();
};
class call_statement : public statement
{
call_expression *m_body;
public:
call_statement(const struct position position, call_expression *body);
virtual void accept(parser_visitor *visitor) override;
call_expression& body();
virtual ~call_statement() override;
};
/**
* List of statements paired with a condition.
*/
class conditional_statements
{
expression *m_prerequisite;
public:
std::vector<statement *> statements;
conditional_statements(expression *prerequisite);
expression& prerequisite();
virtual ~conditional_statements();
};
class return_statement : public statement
{
expression *m_return_expression{ nullptr };
public:
return_statement(const struct position position, expression *return_expression);
virtual void accept(parser_visitor *visitor) override;
expression *return_expression();
virtual ~return_statement() override;
};
class designator_expression : public expression
{
public:
virtual variable_expression *is_variable();
virtual array_access_expression *is_array_access();
virtual field_access_expression *is_field_access();
virtual dereference_expression *is_dereference();
protected:
designator_expression(const struct position position);
};
class variable_expression : public designator_expression
{
std::string m_name;
public:
variable_expression(const struct position position, const std::string& name);
virtual void accept(parser_visitor *visitor) override;
const std::string& name() const;
variable_expression *is_variable() override;
};
class array_access_expression : public designator_expression
{
expression *m_base;
expression *m_index;
public:
array_access_expression(const struct position position, expression *base, expression *index);
virtual void accept(parser_visitor *visitor) override;
expression& base();
expression& index();
array_access_expression *is_array_access() override;
~array_access_expression() override;
};
class field_access_expression : public designator_expression
{
expression *m_base;
std::string m_field;
public:
field_access_expression(const struct position position, expression *base,
const std::string& field);
virtual void accept(parser_visitor *visitor) override;
expression& base();
std::string& field();
field_access_expression *is_field_access() override;
~field_access_expression() override;
};
class dereference_expression : public designator_expression
{
expression *m_base;
public:
dereference_expression(const struct position position, expression *base);
virtual void accept(parser_visitor *visitor) override;
expression& base();
dereference_expression *is_dereference() override;
~dereference_expression() override;
};
class assign_statement : public statement
{
designator_expression *m_lvalue;
expression *m_rvalue;
public:
/**
* \param position Source code position.
* \param lvalue Left-hand side.
* \param rvalue Assigned expression.
*/
assign_statement(const struct position position, designator_expression *lvalue,
expression *rvalue);
virtual void accept(parser_visitor *visitor) override;
designator_expression& lvalue();
expression& rvalue();
virtual ~assign_statement() override;
};
/**
* If-statement.
*/
class if_statement : public statement
{
conditional_statements *m_body;
std::vector<statement *> *m_alternative;
public:
std::vector<conditional_statements *> branches;
if_statement(const struct position position, conditional_statements *body,
std::vector<statement *> *alternative = nullptr);
virtual void accept(parser_visitor *visitor) override;
conditional_statements& body();
std::vector<statement *> *alternative();
virtual ~if_statement() override;
};
/**
* While-statement.
*/
class while_statement : public statement
{
conditional_statements *m_body;
public:
std::vector<conditional_statements *> branches;
while_statement(const struct position position, conditional_statements *body);
virtual void accept(parser_visitor *visitor) override;
conditional_statements& body();
virtual ~while_statement() override;
};
class block : public node
{
public:
std::vector<variable_declaration *> variables;
std::vector<constant_definition *> constants;
std::vector<statement *> body;
block(const struct position position);
virtual void accept(parser_visitor *visitor) override;
virtual ~block() override;
};
class program : public block
{
public:
std::vector<type_definition *> types;
std::vector<procedure_definition *> procedures;
program(const struct position position);
virtual void accept(parser_visitor *visitor) override;
virtual ~program() override;
};
template<typename T>
class number_literal : public literal
{
public:
T value;
number_literal(const struct position position, const T& value)
: literal(position), value(value)
{
}
virtual void accept(parser_visitor *visitor) override
{
visitor->visit(this);
}
};
class defer_statement : public statement
{
public:
std::vector<statement *> statements;
defer_statement(const struct position position);
virtual void accept(parser_visitor *visitor) override;
virtual ~defer_statement() override;
};
class binary_expression : public expression
{
expression *m_lhs;
expression *m_rhs;
binary_operator m_operator;
public:
binary_expression(const struct position position, expression *lhs,
expression *rhs, const binary_operator operation);
virtual void accept(parser_visitor *visitor) override;
expression& lhs();
expression& rhs();
binary_operator operation() const;
virtual ~binary_expression() override;
};
class unary_expression : public expression
{
expression *m_operand;
unary_operator m_operator;
public:
unary_expression(const struct position position, expression *operand,
const unary_operator operation);
virtual void accept(parser_visitor *visitor) override;
expression& operand();
unary_operator operation() const;
virtual ~unary_expression() override;
};
const char *print_binary_operator(const binary_operator operation);
}
}

60
include/elna/boot/driver.h
View File

@ -1,60 +0,0 @@
/* Parsing driver.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#pragma once
#include <list>
#include <optional>
#include "elna/boot/ast.h"
#include "location.hh"
namespace elna
{
namespace boot
{
position make_position(const yy::location& location);
class syntax_error final : public error
{
std::string message;
public:
syntax_error(const std::string& message,
const char *input_file, const yy::location& location);
virtual std::string what() const override;
};
class driver
{
std::list<std::unique_ptr<struct error>> m_errors;
const char *input_file;
public:
std::unique_ptr<program> tree;
driver(const char *input_file);
void error(const yy::location& loc, const std::string& message);
const std::list<std::unique_ptr<struct error>>& errors() const noexcept;
};
constexpr char escape_invalid_char = '\xff';
char escape_char(char escape);
}
}

69
include/elna/boot/result.h
View File

@ -1,69 +0,0 @@
/* Miscellaneous types used across stage boundaries.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#pragma once
#include <cstddef>
#include <string>
namespace elna
{
namespace boot
{
/**
* Position in the source text.
*/
struct position
{
/// Line.
std::size_t line = 1;
/// Column.
std::size_t column = 1;
};
/**
* A compilation error consists of an error message and position.
*/
class error
{
protected:
/**
* Constructs an error.
*
* \param path Source file name.
* \param position Error position in the source text.
*/
error(const char *path, const struct position position);
public:
const struct position position;
const char *path;
virtual ~error() noexcept = default;
/// Error text.
virtual std::string what() const = 0;
/// Error line in the source text.
std::size_t line() const noexcept;
/// Error column in the source text.
std::size_t column() const noexcept;
};
}
}

128
include/elna/boot/symbol.h
View File

@ -1,128 +0,0 @@
/* Symbol definitions.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#pragma once
#include <cstdint>
#include <unordered_map>
#include <string>
#include <memory>
namespace elna
{
namespace boot
{
/**
* Symbol table.
*/
template<typename T, T nothing>
class symbol_table
{
public:
using symbol_ptr = T;
using iterator = typename std::unordered_map<std::string, symbol_ptr>::iterator;
using const_iterator = typename std::unordered_map<std::string, symbol_ptr>::const_iterator;
private:
std::unordered_map<std::string, symbol_ptr> entries;
std::shared_ptr<symbol_table> outer_scope;
public:
/**
* Constructs a new symbol with an optional outer scope.
*
* \param scope Outer scope.
*/
explicit symbol_table(std::shared_ptr<symbol_table> scope = nullptr)
: outer_scope(scope)
{
}
iterator begin()
{
return entries.begin();
}
iterator end()
{
return entries.end();
}
const_iterator cbegin() const
{
return entries.cbegin();
}
const_iterator cend() const
{
return entries.cend();
}
/**
* Looks for symbol in the table by name. Returns nothing if the symbol
* can not be found.
*
* \param name Symbol name.
* \return Symbol from the table if found.
*/
symbol_ptr lookup(const std::string& name)
{
auto entry = entries.find(name);
if (entry != entries.cend())
{
return entry->second;
}
if (this->outer_scope != nullptr)
{
return this->outer_scope->lookup(name);
}
return nothing;
}
/**
* Registers new symbol.
*
* \param name Symbol name.
* \param entry Symbol information.
*
* \return Whether the insertion took place.
*/
bool enter(const std::string& name, symbol_ptr entry)
{
if (lookup(name) == nothing)
{
return entries.insert({ name, entry }).second;
}
else
{
return nothing;
}
}
/**
* Returns the outer scope or nullptr if the this is the global scope.
*
* \return Outer scope.
*/
std::shared_ptr<symbol_table> scope()
{
return this->outer_scope;
}
};
}
}

30
include/elna/gcc/elna-builtins.h
View File

@ -1,30 +0,0 @@
/* Builtin definitions.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-iterator.h"
namespace elna
{
namespace gcc
{
void init_ttree();
}
}

36
include/elna/gcc/elna-diagnostic.h
View File

@ -1,36 +0,0 @@
/* Elna frontend specific diagnostic routines.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#pragma once
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "input.h"
#include "tree.h"
#include "elna/boot/result.h"
namespace elna
{
namespace gcc
{
location_t get_location(const boot::position *position);
std::string print_type(tree type);
}
}

95
include/elna/gcc/elna-generic.h
View File

@ -1,95 +0,0 @@
/* Visitor generating a GENERIC tree.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#pragma once
#include "elna/boot/ast.h"
#include "elna/boot/symbol.h"
#include "elna/gcc/elna-tree.h"
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-iterator.h"
#include <forward_list>
#include <string>
namespace elna
{
namespace gcc
{
class generic_visitor final : public boot::empty_visitor
{
tree current_expression{ NULL_TREE };
std::shared_ptr<symbol_table> symbol_map;
tree build_label_decl(const char *name, location_t loc);
tree build_type(boot::top_type& type);
void enter_scope();
tree leave_scope();
tree lookup(const std::string& name);
void make_if_branch(boot::conditional_statements& branch, tree goto_endif);
tree build_arithmetic_operation(boot::binary_expression *expression,
tree_code operator_code, tree left, tree right);
tree build_comparison_operation(boot::binary_expression *expression,
tree_code operator_code, tree left, tree right);
tree build_bit_logic_operation(boot::binary_expression *expression, tree left, tree right);
tree build_equality_operation(boot::binary_expression *expression, tree left, tree right);
void build_procedure_call(location_t call_location,
tree symbol, const std::vector<boot::expression *>& arguments);
void build_record_call(location_t call_location,
tree symbol, const std::vector<boot::expression *>& arguments);
public:
generic_visitor(std::shared_ptr<symbol_table> symbol_table);
void visit(boot::program *program) override;
void visit(boot::procedure_definition *definition) override;
void visit(boot::call_expression *expression) override;
void visit(boot::cast_expression *expression) override;
void visit(boot::type_expression *expression) override;
void visit(boot::number_literal<std::int32_t> *literal) override;
void visit(boot::number_literal<std::uint32_t> *literal) override;
void visit(boot::number_literal<double> *literal) override;
void visit(boot::number_literal<bool> *boolean) override;
void visit(boot::number_literal<unsigned char> *character) override;
void visit(boot::number_literal<std::nullptr_t> *) override;
void visit(boot::number_literal<std::string> *string) override;
void visit(boot::binary_expression *expression) override;
void visit(boot::unary_expression *expression) override;
void visit(boot::constant_definition *definition) override;
void visit(boot::type_definition *definition) override;
void visit(boot::variable_declaration *declaration) override;
void visit(boot::variable_expression *expression) override;
void visit(boot::array_access_expression *expression) override;
void visit(boot::field_access_expression *expression) override;
void visit(boot::dereference_expression *expression) override;
void visit(boot::assign_statement *statement) override;
void visit(boot::if_statement *statement) override;
void visit(boot::while_statement *statement) override;
void visit(boot::call_statement *statement) override;
void visit(boot::return_statement *statement) override;
void visit(boot::defer_statement *statement) override;
};
}
}

76
include/elna/gcc/elna-tree.h
View File

@ -1,76 +0,0 @@
/* Utilities to manipulate GCC trees.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#pragma once
#include <forward_list>
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-iterator.h"
#include "stringpool.h"
#include "elna/boot/ast.h"
#include "elna/boot/symbol.h"
namespace elna
{
namespace gcc
{
using symbol_table = boot::symbol_table<tree, NULL_TREE>;
bool is_pointer_type(tree type);
bool is_integral_type(tree type);
bool is_numeric_type(tree type);
bool is_array_type(tree type);
bool is_procedure_type(tree type);
bool is_void_type(tree type);
/**
* \param type The type to evaluate.
* \return Whether the given type is record or union.
*/
bool is_aggregate_type(tree type);
/**
* \param lhs Left hand value.
* \param rhs Right hand value.
* \return Whether rhs can be assigned to lhs.
*/
bool are_compatible_pointers(tree lhs_type, tree rhs);
/**
* \param assignee Assignee.
* \param assignee Assignment.
* \return Whether an expression assignment can be assigned to a variable of type assignee.
*/
bool is_assignable_from(tree assignee, tree assignment);
void append_statement(tree statement_tree);
void defer(tree statement_tree);
tree chain_defer();
tree do_pointer_arithmetic(boot::binary_operator binary_operator, tree left, tree right);
tree build_binary_operation(bool condition, boot::binary_expression *expression,
tree_code operator_code, tree left, tree right, tree target_type);
tree build_arithmetic_operation(boot::binary_expression *expression,
tree_code operator_code, tree left, tree right);
tree build_field(location_t location, tree record_type, const std::string name, tree type);
}
}

92
include/elna/gcc/elna1.h
View File

@ -1,92 +0,0 @@
/* Language-dependent hooks for Elna.
Copyright (C) 2025 Free Software Foundation, Inc.
GCC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
enum elna_tree_index
{
ELNA_TI_INT_TYPE,
ELNA_TI_WORD_TYPE,
ELNA_TI_CHAR_TYPE,
ELNA_TI_BOOL_TYPE,
ELNA_TI_BYTE_TYPE,
ELNA_TI_FLOAT_TYPE,
ELNA_TI_STRING_TYPE,
ELNA_TI_BOOL_TRUE,
ELNA_TI_BOOL_FALSE,
ELNA_TI_POINTER_NIL,
ELNA_TI_STRING_PTR_FIELD,
ELNA_TI_STRING_LENGTH_FIELD,
ELNA_TI_MAX
};
extern GTY(()) tree elna_global_trees[ELNA_TI_MAX];
extern GTY(()) hash_map<nofree_string_hash, tree> *elna_global_decls;
#define elna_int_type_node elna_global_trees[ELNA_TI_INT_TYPE]
#define elna_word_type_node elna_global_trees[ELNA_TI_WORD_TYPE]
#define elna_char_type_node elna_global_trees[ELNA_TI_CHAR_TYPE]
#define elna_bool_type_node elna_global_trees[ELNA_TI_BOOL_TYPE]
#define elna_byte_type_node elna_global_trees[ELNA_TI_BYTE_TYPE]
#define elna_float_type_node elna_global_trees[ELNA_TI_FLOAT_TYPE]
#define elna_string_type_node elna_global_trees[ELNA_TI_STRING_TYPE]
#define elna_bool_true_node elna_global_trees[ELNA_TI_BOOL_TRUE]
#define elna_bool_false_node elna_global_trees[ELNA_TI_BOOL_FALSE]
#define elna_pointer_nil_node elna_global_trees[ELNA_TI_POINTER_NIL]
#define elna_string_ptr_field_node elna_global_trees[ELNA_TI_STRING_PTR_FIELD]
#define elna_string_length_field_node elna_global_trees[ELNA_TI_STRING_LENGTH_FIELD]
/* Language-dependent contents of a type. */
struct GTY (()) lang_type
{
};
/* Language-dependent contents of a decl. */
struct GTY (()) lang_decl
{
};
struct GTY (()) defer_scope
{
tree defer_block;
tree try_statements;
};
struct GTY ((chain_next ("%h.level_chain"))) binding_level
{
// A block chain is needed to call defer statements beloning to each block.
tree blocks;
// Parent level.
struct binding_level *level_chain;
// Statements before the first defer has been seen.
tree statement_list;
// Defer statement coupled with statements following it.
vec<defer_scope, va_gc> *defers;
};
struct GTY (()) language_function
{
// Local variables and constants.
tree names;
// Lexical scope.
struct binding_level *binding_level;
};
#define f_binding_level DECL_STRUCT_FUNCTION(current_function_decl)->language->binding_level
#define f_names DECL_STRUCT_FUNCTION(current_function_decl)->language->names

326
lib/Language/Elna/Architecture/RiscV.hs Normal file
View File

@ -0,0 +1,326 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Architecture.RiscV
( BaseOpcode(..)
, RelocationType(..)
, Funct3(..)
, Funct7(..)
, Funct12(..)
, Instruction(..)
, Type(..)
, XRegister(..)
, baseOpcode
, funct3
, funct12
, instruction
, xRegister
) where
import qualified Data.ByteString.Builder as ByteString.Builder
import Data.Bits (Bits(..))
import Data.Text (Text)
import Data.Word (Word8, Word32)
data XRegister
= Zero
| RA
| SP
| GP
| TP
| T0
| T1
| T2
| S0
| S1
| A0
| A1
| A2
| A3
| A4
| A5
| A6
| A7
| S2
| S3
| S4
| S5
| S6
| S7
| S8
| S9
| S10
| S11
| T3
| T4
| T5
| T6
deriving Eq
data Funct3
= ADDI
| SLTI
| SLTIU
| ANDI
| ORI
| XORI
| SLLI
| SRLI
| SRAI
| ADD
| SLT
| SLTU
| AND
| OR
| XOR
| SLL
| SRL
| SUB
| SRA
| BEQ
| BNE
| BLT
| BLTU
| BGE
| BGEU
| FENCE
| FENCEI
| CSRRW
| CSRRS
| CSRRC
| CSRRWI
| CSRRSI
| CSRRCI
| PRIV
| SB
| SH
| SW
| LB
| LH
| LW
| LBU
| LHU
| JALR
| MUL
| MULH
| MULHSU
| MULHU
| DIV
| DIVU
| REM
| REMU
deriving Eq
data Funct12
= ECALL
| EBREAK
deriving Eq
newtype Funct7 = Funct7
{ funct7 :: Word8
} deriving Eq
data BaseOpcode
= OpImm
| Lui
| Auipc
| Op
| Jal
| Jalr
| Branch
| Load
| Store
| MiscMem
| System
deriving Eq
data Type
= I XRegister Funct3 XRegister Word32
| S Word32 Funct3 XRegister XRegister
| B Word32 Funct3 XRegister XRegister
| R XRegister Funct3 XRegister XRegister Funct7
| U XRegister Word32
| J XRegister Word32
| Type XRegister Funct3 XRegister Funct12 -- Privileged.
deriving Eq
data RelocationType
= RLower12I XRegister Funct3 XRegister Text
| RLower12S Text Funct3 XRegister XRegister
| RHigher20 XRegister Text -- Type U.
| RBranch Text Funct3 XRegister XRegister -- Type B.
| RJal XRegister Text -- Type J.
deriving Eq
data Instruction
= BaseInstruction BaseOpcode Type
| RelocatableInstruction BaseOpcode RelocationType
| CallInstruction Text
deriving Eq
xRegister :: XRegister -> Word8
xRegister Zero = 0
xRegister RA = 1
xRegister SP = 2
xRegister GP = 3
xRegister TP = 4
xRegister T0 = 5
xRegister T1 = 6
xRegister T2 = 7
xRegister S0 = 8
xRegister S1 = 9
xRegister A0 = 10
xRegister A1 = 11
xRegister A2 = 12
xRegister A3 = 13
xRegister A4 = 14
xRegister A5 = 15
xRegister A6 = 16
xRegister A7 = 17
xRegister S2 = 18
xRegister S3 = 19
xRegister S4 = 20
xRegister S5 = 21
xRegister S6 = 22
xRegister S7 = 23
xRegister S8 = 24
xRegister S9 = 25
xRegister S10 = 26
xRegister S11 = 27
xRegister T3 = 28
xRegister T4 = 29
xRegister T5 = 30
xRegister T6 = 31
funct3 :: Funct3 -> Word8
funct3 ADDI = 0b000
funct3 SLTI = 0b001
funct3 SLTIU = 0b011
funct3 ANDI = 0b111
funct3 ORI = 0b110
funct3 XORI = 0b100
funct3 SLLI = 0b000
funct3 SRLI = 0b101
funct3 SRAI = 0b101
funct3 ADD = 0b000
funct3 SLT = 0b010
funct3 SLTU = 0b011
funct3 AND = 0b111
funct3 OR = 0b110
funct3 XOR = 0b100
funct3 SLL = 0b001
funct3 SRL = 0b101
funct3 SUB = 0b000
funct3 SRA = 0b101
funct3 BEQ = 0b000
funct3 BNE = 0b001
funct3 BLT = 0b100
funct3 BLTU = 0b110
funct3 BGE = 0b101
funct3 BGEU = 0b111
funct3 FENCE = 0b000
funct3 FENCEI = 0b001
funct3 CSRRW = 0b001
funct3 CSRRS = 0b010
funct3 CSRRC = 0b011
funct3 CSRRWI = 0b101
funct3 CSRRSI = 0b110
funct3 CSRRCI = 0b111
funct3 PRIV = 0b000
funct3 SB = 0b000
funct3 SH = 0b001
funct3 SW = 0b010
funct3 LB = 0b000
funct3 LH = 0b001
funct3 LW = 0b010
funct3 LBU = 0b100
funct3 LHU = 0b101
funct3 JALR = 0b000
funct3 MUL = 0b000
funct3 MULH = 0b001
funct3 MULHSU = 0b010
funct3 MULHU = 0b011
funct3 DIV = 0b100
funct3 DIVU = 0b101
funct3 REM = 0b110
funct3 REMU = 0b111
funct12 :: Funct12 -> Word8
funct12 ECALL = 0b000000000000
funct12 EBREAK = 0b000000000001
baseOpcode :: BaseOpcode -> Word8
baseOpcode OpImm = 0b0010011
baseOpcode Lui = 0b0110111
baseOpcode Auipc = 0b0010111
baseOpcode Op = 0b0110011
baseOpcode Jal = 0b1101111
baseOpcode Jalr = 0b1100111
baseOpcode Branch = 0b1100011
baseOpcode Load = 0b0000011
baseOpcode Store = 0b0100011
baseOpcode MiscMem = 0b0001111
baseOpcode System = 0b1110011
type' :: Type -> Word32
type' (I rd funct3' rs1 immediate)
= (fromIntegral (xRegister rd) `shiftL` 7)
.|. (fromIntegral (funct3 funct3') `shiftL` 12)
.|. (fromIntegral (xRegister rs1) `shiftL` 15)
.|. (immediate `shiftL` 20);
type' (S immediate funct3' rs1 rs2)
= ((immediate .&. 0x1f) `shiftL` 7)
.|. (fromIntegral (funct3 funct3') `shiftL` 12)
.|. (fromIntegral (xRegister rs1) `shiftL` 15)
.|. (fromIntegral (xRegister rs2) `shiftL` 20)
.|. ((immediate .&. 0xfe0) `shiftL` 20)
type' (B immediate funct3' rs1 rs2)
= ((immediate .&. 0x800) `shiftR` 4)
.|. ((immediate .&. 0x1e) `shiftL` 7)
.|. (fromIntegral (funct3 funct3') `shiftL` 12)
.|. (fromIntegral (xRegister rs1) `shiftL` 15)
.|. (fromIntegral (xRegister rs2) `shiftL` 20)
.|. ((immediate .&. 0x7e0) `shiftL` 20)
.|. ((immediate .&. 0x1000) `shiftL` 19)
type' (R rd funct3' rs1 rs2 funct7')
= (fromIntegral (xRegister rd) `shiftL` 7)
.|. (fromIntegral (funct3 funct3') `shiftL` 12)
.|. (fromIntegral (xRegister rs1) `shiftL` 15)
.|. (fromIntegral (xRegister rs2) `shiftL` 20)
.|. (fromIntegral (funct7 funct7') `shiftL` 25);
type' (U rd immediate)
= (fromIntegral (xRegister rd) `shiftL` 7)
.|. (immediate `shiftL` 12)
type' (J rd immediate)
= (fromIntegral (xRegister rd) `shiftL` 7)
.|. (immediate .&. 0xff000)
.|. ((immediate .&. 0x800) `shiftL` 9)
.|. ((immediate .&. 0x7fe) `shiftL` 20)
.|. ((immediate .&. 0x100000) `shiftL` 11);
type' (Type rd funct3' rs1 funct12')
= (fromIntegral (xRegister rd) `shiftL` 7)
.|. (fromIntegral (funct3 funct3') `shiftL` 12)
.|. (fromIntegral (xRegister rs1) `shiftL` 15)
.|. (fromIntegral (funct12 funct12') `shiftL` 20);
relocationType :: RelocationType -> Word32
relocationType (RLower12I rd funct3' rs1 _) = type' $ I rd funct3' rs1 0
relocationType (RLower12S _ funct3' rs1 rs2) = type' $ S 0 funct3' rs1 rs2
relocationType (RHigher20 rd _) = type' $ U rd 0
relocationType (RBranch _ funct3' rs1 rs2) = type' $ B 0 funct3' rs1 rs2
relocationType (RJal rd _) = type' $ J rd 0
instruction :: Instruction -> ByteString.Builder.Builder
instruction = \case
(BaseInstruction base instructionType) -> go base $ type' instructionType
(RelocatableInstruction base instructionType) -> go base $ relocationType instructionType
(CallInstruction _) -> foldMap instruction
[ BaseInstruction Auipc $ U RA 0
, BaseInstruction Jalr $ I RA JALR RA 0
]
where
go base instructionType
= ByteString.Builder.word32LE
$ fromIntegral (baseOpcode base)
.|. instructionType

182
lib/Language/Elna/Backend/Allocator.hs Normal file
View File

@ -0,0 +1,182 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Backend.Allocator
( MachineConfiguration(..)
, Store(..)
, allocate
) where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Int (Int32)
import Data.Vector (Vector)
import Language.Elna.Backend.Intermediate
( ProcedureQuadruples(..)
, Operand(..)
, Quadruple(..)
, Variable(..)
)
import Language.Elna.Location (Identifier(..))
import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
import Control.Monad.Trans.State (State, runState)
import GHC.Records (HasField(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
import Data.List ((!?))
import Language.Elna.Frontend.SymbolTable (Info(..), SymbolTable)
import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
data Store r
= RegisterStore r
| StackStore Int32 r
data AllocationError
= OutOfRegistersError
| UnexpectedProcedureInfoError Info
| UndefinedSymbolError Identifier
deriving Eq
instance Show AllocationError
where
show OutOfRegistersError = "Ran out of registers during register allocation"
show (UnexpectedProcedureInfoError info) =
"Expected to encounter a procedure, got: " <> show info
show (UndefinedSymbolError identifier) =
concat ["Symbol \"", show identifier, "\" is not defined"]
newtype MachineConfiguration r = MachineConfiguration
{ temporaryRegisters :: [r]
}
newtype MachineState = MachineState
{ symbolTable :: SymbolTable
} deriving (Eq, Show)
newtype Allocator r a = Allocator
{ runAllocator :: ExceptT AllocationError (ReaderT (MachineConfiguration r) (State MachineState)) a
}
instance forall r. Functor (Allocator r)
where
fmap f = Allocator . fmap f . runAllocator
instance forall r. Applicative (Allocator r)
where
pure = Allocator . pure
(Allocator x) <*> (Allocator y) = Allocator $ x <*> y
instance forall r. Monad (Allocator r)
where
(Allocator allocator) >>= f = Allocator $ allocator >>= (runAllocator . f)
allocate
:: forall r
. MachineConfiguration r
-> SymbolTable
-> HashMap Identifier (Vector (Quadruple Variable))
-> Either AllocationError (HashMap Identifier (ProcedureQuadruples (Store r)))
allocate machineConfiguration globalTable = HashMap.traverseWithKey function
where
run localTable = flip runState (MachineState{ symbolTable = localTable })
. flip runReaderT machineConfiguration
. runExceptT
. runAllocator
. mapM quadruple
function :: Identifier -> Vector (Quadruple Variable) -> Either AllocationError (ProcedureQuadruples (Store r))
function procedureName quadruples' =
case SymbolTable.lookup procedureName globalTable of
Just (ProcedureInfo localTable _) ->
let (result, lastState) = run localTable quadruples'
in makeResult lastState <$> result
Just anotherInfo -> Left $ UnexpectedProcedureInfoError anotherInfo
Nothing -> Left $ UndefinedSymbolError procedureName
makeResult MachineState{ symbolTable } result = ProcedureQuadruples
{ quadruples = result
, stackSize = fromIntegral $ SymbolTable.size symbolTable * 4
}
quadruple :: Quadruple Variable -> Allocator r (Quadruple (Store r))
quadruple = \case
StartQuadruple -> pure StartQuadruple
StopQuadruple -> pure StopQuadruple
ParameterQuadruple operand1 -> ParameterQuadruple
<$> operand operand1
CallQuadruple name count -> pure $ CallQuadruple name count
AddQuadruple operand1 operand2 variable -> AddQuadruple
<$> operand operand1
<*> operand operand2
<*> storeVariable variable
SubtractionQuadruple operand1 operand2 variable -> SubtractionQuadruple
<$> operand operand1
<*> operand operand2
<*> storeVariable variable
NegationQuadruple operand1 variable -> NegationQuadruple
<$> operand operand1
<*> storeVariable variable
ProductQuadruple operand1 operand2 variable -> ProductQuadruple
<$> operand operand1
<*> operand operand2
<*> storeVariable variable
DivisionQuadruple operand1 operand2 variable -> DivisionQuadruple
<$> operand operand1
<*> operand operand2
<*> storeVariable variable
LabelQuadruple label -> pure $ LabelQuadruple label
GoToQuadruple label -> pure $ GoToQuadruple label
EqualQuadruple operand1 operand2 goToLabel -> EqualQuadruple
<$> operand operand1
<*> operand operand2
<*> pure goToLabel
NonEqualQuadruple operand1 operand2 goToLabel -> NonEqualQuadruple
<$> operand operand1
<*> operand operand2
<*> pure goToLabel
LessQuadruple operand1 operand2 goToLabel -> LessQuadruple
<$> operand operand1
<*> operand operand2
<*> pure goToLabel
GreaterQuadruple operand1 operand2 goToLabel -> do
operand1' <- operand operand1
operand2' <- operand operand2
pure $ GreaterQuadruple operand1' operand2' goToLabel
LessOrEqualQuadruple operand1 operand2 goToLabel -> LessOrEqualQuadruple
<$> operand operand1
<*> operand operand2
<*> pure goToLabel
GreaterOrEqualQuadruple operand1 operand2 goToLabel -> GreaterOrEqualQuadruple
<$> operand operand1
<*> operand operand2
<*> pure goToLabel
AssignQuadruple operand1 variable -> AssignQuadruple
<$> operand operand1
<*> storeVariable variable
ArrayAssignQuadruple operand1 operand2 variable -> ArrayAssignQuadruple
<$> operand operand1
<*> operand operand2
<*> storeVariable variable
ArrayQuadruple variable1 operand1 variable2 -> ArrayQuadruple
<$> storeVariable variable1
<*> operand operand1
<*> storeVariable variable2
operand :: Operand Variable -> Allocator r (Operand (Store r))
operand (IntOperand literalOperand) = pure $ IntOperand literalOperand
operand (VariableOperand variableOperand) =
VariableOperand <$> storeVariable variableOperand
storeVariable :: Variable -> Allocator r (Store r)
storeVariable (TempVariable index) = do
temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters"
maybe (Allocator $ throwE OutOfRegistersError) (pure . RegisterStore)
$ temporaryRegisters' !? fromIntegral index
storeVariable (LocalVariable index) = do
temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters"
maybe (Allocator $ throwE OutOfRegistersError) (pure . StackStore (fromIntegral (succ index) * (-4)))
$ temporaryRegisters' !? pred (length temporaryRegisters' - fromIntegral index)
storeVariable (ParameterVariable index) = do
temporaryRegisters' <- Allocator $ lift $ asks $ getField @"temporaryRegisters"
maybe (Allocator $ throwE OutOfRegistersError) (pure . StackStore (fromIntegral index * 4))
$ temporaryRegisters' !? fromIntegral index

66
lib/Language/Elna/Backend/Intermediate.hs Normal file
View File

@ -0,0 +1,66 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Backend.Intermediate
( ProcedureQuadruples(..)
, Operand(..)
, Quadruple(..)
, Label(..)
, Variable(..)
) where
import Data.Int (Int32)
import Data.Vector (Vector)
import Data.Word (Word32)
import Data.Text (Text)
import qualified Data.Text as Text
newtype Label = Label { unLabel :: Text }
deriving Eq
instance Show Label
where
show (Label label) = '.' : Text.unpack label
data Variable = TempVariable Word32 | LocalVariable Word32 | ParameterVariable Word32
deriving Eq
instance Show Variable
where
show (LocalVariable variable) = '@' : show variable
show (TempVariable variable) = '$' : show variable
show (ParameterVariable variable) = '%' : show variable
data Operand v
= IntOperand Int32
| VariableOperand v
deriving (Eq, Show)
data ProcedureQuadruples v = ProcedureQuadruples
{ quadruples :: Vector (Quadruple v)
, stackSize :: Word32
} deriving (Eq, Show)
data Quadruple v
= StartQuadruple
| StopQuadruple
| ParameterQuadruple (Operand v)
| CallQuadruple Text Word32
| AddQuadruple (Operand v) (Operand v) v
| SubtractionQuadruple (Operand v) (Operand v) v
| NegationQuadruple (Operand v) v
| ProductQuadruple (Operand v) (Operand v) v
| DivisionQuadruple (Operand v) (Operand v) v
| GoToQuadruple Label
| AssignQuadruple (Operand v) v
| ArrayQuadruple v (Operand v) v
| ArrayAssignQuadruple (Operand v) (Operand v) v
| LessOrEqualQuadruple (Operand v) (Operand v) Label
| GreaterOrEqualQuadruple (Operand v) (Operand v) Label
| GreaterQuadruple (Operand v) (Operand v) Label
| LessQuadruple (Operand v) (Operand v) Label
| NonEqualQuadruple (Operand v) (Operand v) Label
| EqualQuadruple (Operand v) (Operand v) Label
| LabelQuadruple Label
deriving (Eq, Show)

37
lib/Language/Elna/Driver.hs Normal file
View File

@ -0,0 +1,37 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Driver
( Driver(..)
, IntermediateStage(..)
, drive
, execParser
) where
import Data.Maybe (fromMaybe)
import Language.Elna.Driver.CommandLine
( CommandLine(..)
, IntermediateStage(..)
, commandLine
)
import Options.Applicative (execParser)
import System.FilePath (replaceExtension, takeFileName)
data Driver = Driver
{ input :: FilePath
, output :: FilePath
, intermediateStage :: Maybe IntermediateStage
} deriving (Eq, Show)
drive :: IO Driver
drive = rewrite <$> execParser commandLine
where
rewrite CommandLine{..} =
let defaultOutputName = replaceExtension (takeFileName input) "o"
outputName = fromMaybe defaultOutputName output
in Driver
{ input = input
, output = outputName
, intermediateStage = intermediateStage
}

69
lib/Language/Elna/Driver/CommandLine.hs Normal file
View File

@ -0,0 +1,69 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Driver.CommandLine
( CommandLine(..)
, IntermediateStage(..)
, commandLine
) where
import Options.Applicative
( Parser
, ParserInfo(..)
, argument
, flag'
, fullDesc
, help
, helper
, info
, long
, metavar
, optional
, progDesc
, short
, str
, strOption
)
import Control.Applicative (Alternative(..), (<**>))
data IntermediateStage
= ParseStage
| ValidateStage
| CodeGenStage
deriving (Eq, Show)
data CommandLine = CommandLine
{ input :: FilePath
, output :: Maybe FilePath
, intermediateStage :: Maybe IntermediateStage
} deriving (Eq, Show)
intermediateStageP :: Parser IntermediateStage
intermediateStageP
= flag' ParseStage parseStageP
<|> flag' ValidateStage validateStageP
<|> flag' CodeGenStage codeGenStageP
where
parseStageP = long "parse"
<> help "Run the lexer and parser, but stop before assembly generation"
validateStageP = long "validate"
<> help "Run through the semantic analysis stage, stopping before TAC generation"
codeGenStageP = long "codegen"
<> help "Perform lexing, parsing, and assembly generation, but stop before code emission"
commandLineP :: Parser CommandLine
commandLineP = CommandLine
<$> argument str inFile
<*> optional (strOption outFile)
<*> optional intermediateStageP
where
inFile = metavar "INFILE" <> help "Input file."
outFile = long "output"
<> short 'o'
<> metavar "OUTFILE"
<> help "Output file."
commandLine :: ParserInfo CommandLine
commandLine = info (commandLineP <**> helper)
$ fullDesc <> progDesc "Elna compiler."

210
lib/Language/Elna/Frontend/AST.hs Normal file
View File

@ -0,0 +1,210 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Frontend.AST
( Declaration(..)
, Identifier(..)
, Parameter(..)
, Program(..)
, Statement(..)
, TypeExpression(..)
, VariableDeclaration(..)
, VariableAccess(..)
, Condition(..)
, Expression(..)
, Literal(..)
) where
import Data.Char (chr)
import Data.Int (Int32)
import Data.List (intercalate)
import Data.Word (Word8)
import Language.Elna.Location (Identifier(..), showArrayType)
import Numeric (showHex)
import Data.Bifunctor (Bifunctor(bimap))
newtype Program = Program [Declaration]
deriving Eq
instance Show Program
where
show (Program declarations) = unlines (show <$> declarations)
data Declaration
= ProcedureDeclaration Identifier [Parameter] [VariableDeclaration] [Statement]
| TypeDefinition Identifier TypeExpression
deriving Eq
instance Show Declaration
where
show (TypeDefinition identifier typeExpression) =
concat ["type ", show identifier, " = ", show typeExpression, ";"]
show (ProcedureDeclaration procedureName parameters variables body)
= "proc " <> show procedureName <> showParameters parameters <> " {\n"
<> unlines ((" " <>) . show <$> variables)
<> unlines ((" " <>) . show <$> body)
<> "}"
data Parameter = Parameter Identifier TypeExpression Bool
deriving Eq
instance Show Parameter
where
show (Parameter identifier typeName ref) = concat
[ if ref then "ref " else ""
, show identifier, ": ", show typeName
]
showParameters :: [Parameter] -> String
showParameters parameters =
"(" <> intercalate ", " (show <$> parameters) <> ")"
data TypeExpression
= NamedType Identifier
| ArrayType Literal TypeExpression
deriving Eq
instance Show TypeExpression
where
show (NamedType typeName) = show typeName
show (ArrayType elementCount typeName) =
showArrayType elementCount typeName
data Statement
= EmptyStatement
| IfStatement Condition Statement (Maybe Statement)
| AssignmentStatement VariableAccess Expression
| WhileStatement Condition Statement
| CompoundStatement [Statement]
| CallStatement Identifier [Expression]
deriving Eq
instance Show Statement
where
show EmptyStatement = ";"
show (IfStatement condition if' else') = concat
[ "if (", show condition, ") "
, show if'
, maybe "" ((<> " else ") . show) else'
]
show (AssignmentStatement lhs rhs) =
concat [show lhs, " := ", show rhs, ";"]
show (WhileStatement expression statement) =
concat ["while (", show expression, ") ", show statement, ";"]
show (CompoundStatement statements) =
concat ["{\n", unlines (show <$> statements), " }"]
show (CallStatement name parameters) = show name <> "("
<> intercalate ", " (show <$> parameters) <> ")"
data VariableDeclaration =
VariableDeclaration Identifier TypeExpression
deriving Eq
data Literal
= DecimalLiteral Int32
| HexadecimalLiteral Int32
| CharacterLiteral Word8
deriving Eq
instance Show Literal
where
show (DecimalLiteral integer) = show integer
show (HexadecimalLiteral integer) = '0' : 'x' : showHex integer ""
show (CharacterLiteral character) =
'\'' : chr (fromEnum character) : ['\'']
instance Ord Literal
where
compare x y = compare (int32Literal x) (int32Literal y)
instance Num Literal
where
x + y = DecimalLiteral $ int32Literal x + int32Literal y
x * y = DecimalLiteral $ int32Literal x * int32Literal y
abs (DecimalLiteral x) = DecimalLiteral $ abs x
abs (HexadecimalLiteral x) = HexadecimalLiteral $ abs x
abs (CharacterLiteral x) = CharacterLiteral $ abs x
negate (DecimalLiteral x) = DecimalLiteral $ negate x
negate (HexadecimalLiteral x) = HexadecimalLiteral $ negate x
negate (CharacterLiteral x) = CharacterLiteral $ negate x
signum (DecimalLiteral x) = DecimalLiteral $ signum x
signum (HexadecimalLiteral x) = HexadecimalLiteral $ signum x
signum (CharacterLiteral x) = CharacterLiteral $ signum x
fromInteger = DecimalLiteral . fromInteger
instance Real Literal
where
toRational (DecimalLiteral integer) = toRational integer
toRational (HexadecimalLiteral integer) = toRational integer
toRational (CharacterLiteral integer) = toRational integer
instance Enum Literal
where
toEnum = DecimalLiteral . fromIntegral
fromEnum = fromEnum . int32Literal
instance Integral Literal
where
toInteger = toInteger . int32Literal
quotRem x y = bimap DecimalLiteral DecimalLiteral
$ quotRem (int32Literal x) (int32Literal y)
int32Literal :: Literal -> Int32
int32Literal (DecimalLiteral integer) = integer
int32Literal (HexadecimalLiteral integer) = integer
int32Literal (CharacterLiteral integer) = fromIntegral integer
instance Show VariableDeclaration
where
show (VariableDeclaration identifier typeExpression) =
concat ["var ", show identifier, ": " <> show typeExpression, ";"]
data Expression
= LiteralExpression Literal
| SumExpression Expression Expression
| SubtractionExpression Expression Expression
| NegationExpression Expression
| ProductExpression Expression Expression
| DivisionExpression Expression Expression
| VariableExpression VariableAccess
deriving Eq
instance Show Expression
where
show (LiteralExpression literal) = show literal
show (SumExpression lhs rhs) = concat [show lhs, " + ", show rhs]
show (SubtractionExpression lhs rhs) = concat [show lhs, " - ", show rhs]
show (NegationExpression negation) = '-' : show negation
show (ProductExpression lhs rhs) = concat [show lhs, " * ", show rhs]
show (DivisionExpression lhs rhs) = concat [show lhs, " / ", show rhs]
show (VariableExpression variable) = show variable
data VariableAccess
= VariableAccess Identifier
| ArrayAccess VariableAccess Expression
deriving Eq
instance Show VariableAccess
where
show (VariableAccess variableName) = show variableName
show (ArrayAccess arrayAccess elementIndex) =
concat [show arrayAccess, "[", show elementIndex, "]"]
data Condition
= EqualCondition Expression Expression
| NonEqualCondition Expression Expression
| LessCondition Expression Expression
| GreaterCondition Expression Expression
| LessOrEqualCondition Expression Expression
| GreaterOrEqualCondition Expression Expression
deriving Eq
instance Show Condition
where
show (EqualCondition lhs rhs) = concat [show lhs, " = ", show rhs]
show (NonEqualCondition lhs rhs) = concat [show lhs, " # ", show rhs]
show (LessCondition lhs rhs) = concat [show lhs, " < ", show rhs]
show (GreaterCondition lhs rhs) = concat [show lhs, " > ", show rhs]
show (LessOrEqualCondition lhs rhs) = concat [show lhs, " <= ", show rhs]
show (GreaterOrEqualCondition lhs rhs) = concat [show lhs, " >= ", show rhs]

211
lib/Language/Elna/Frontend/NameAnalysis.hs Normal file
View File

@ -0,0 +1,211 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Frontend.NameAnalysis
( nameAnalysis
, Error(..)
) where
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Vector as Vector
import qualified Language.Elna.Frontend.AST as AST
import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
import Language.Elna.Frontend.SymbolTable
( SymbolTable
, Info(..)
, ParameterInfo(..)
)
import Control.Monad.Trans.Except (Except, runExcept, throwE)
import Data.Functor ((<&>))
import Language.Elna.Location (Identifier(..))
import Language.Elna.Frontend.Types (Type(..))
import Data.Foldable (traverse_)
import Control.Monad (foldM, unless)
data Error
= UndefinedTypeError Identifier
| UnexpectedTypeInfoError Info
| IdentifierAlreadyDefinedError Identifier
| UndefinedSymbolError Identifier
| UnexpectedArrayByValue Identifier
deriving Eq
instance Show Error
where
show (UndefinedTypeError identifier) =
concat ["Type \"", show identifier, "\" is not defined"]
show (UnexpectedTypeInfoError info) = show info
<> " expected to be a type"
show (IdentifierAlreadyDefinedError identifier) =
concat ["The identifier \"", show identifier, "\" is already defined"]
show (UndefinedSymbolError identifier) =
concat ["Symbol \"", show identifier, "\" is not defined"]
show (UnexpectedArrayByValue identifier) = concat
[ "Array \""
, show identifier
, "\" cannot be passed by value, only by reference"
]
newtype NameAnalysis a = NameAnalysis
{ runNameAnalysis :: Except Error a
}
instance Functor NameAnalysis
where
fmap f (NameAnalysis x) = NameAnalysis $ f <$> x
instance Applicative NameAnalysis
where
pure = NameAnalysis . pure
(NameAnalysis f) <*> (NameAnalysis x) = NameAnalysis $ f <*> x
instance Monad NameAnalysis
where
(NameAnalysis x) >>= f = NameAnalysis $ x >>= (runNameAnalysis . f)
nameAnalysis :: AST.Program -> Either Error SymbolTable
nameAnalysis = runExcept
. runNameAnalysis
. program SymbolTable.builtInSymbolTable
program :: SymbolTable -> AST.Program -> NameAnalysis SymbolTable
program symbolTable (AST.Program declarations) = do
globalTable <- foldM procedureDeclaration symbolTable declarations
foldM declaration globalTable declarations
procedureDeclaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable
procedureDeclaration globalTable = \case
(AST.ProcedureDeclaration identifier parameters _ _)
-> mapM (parameter globalTable) parameters
>>= enterOrFail identifier
. ProcedureInfo SymbolTable.empty
. Vector.fromList
(AST.TypeDefinition identifier typeExpression)
-> dataType globalTable typeExpression
>>= enterOrFail identifier . SymbolTable.TypeInfo
where
enterOrFail identifier declarationInfo =
maybe (NameAnalysis $ throwE $ IdentifierAlreadyDefinedError identifier) pure
$ SymbolTable.enter identifier declarationInfo globalTable
declaration :: SymbolTable -> AST.Declaration -> NameAnalysis SymbolTable
declaration globalTable (AST.ProcedureDeclaration identifier parameters variables body) = do
variableInfo <- mapM (variableDeclaration globalTable) variables
parameterInfo <- mapM (parameterToVariableInfo globalTable) parameters
procedureTable <- fmap (SymbolTable.scope globalTable)
$ either (NameAnalysis . throwE . IdentifierAlreadyDefinedError . NonEmpty.head) pure
$ SymbolTable.fromList
$ parameterInfo <> variableInfo
traverse_ (statement procedureTable) body
pure $ SymbolTable.update (updater procedureTable) identifier globalTable
where
updater procedureTable (ProcedureInfo _ parameters') = Just
$ ProcedureInfo procedureTable parameters'
updater _ _ = Nothing
declaration globalTable (AST.TypeDefinition _ _) = pure globalTable
parameterToVariableInfo :: SymbolTable -> AST.Parameter -> NameAnalysis (Identifier, Info)
parameterToVariableInfo symbolTable (AST.Parameter identifier typeExpression isReferenceParameter')
= (identifier,) . VariableInfo isReferenceParameter'
<$> dataType symbolTable typeExpression
variableDeclaration :: SymbolTable -> AST.VariableDeclaration -> NameAnalysis (Identifier, Info)
variableDeclaration globalTable (AST.VariableDeclaration identifier typeExpression)
= (identifier,) . VariableInfo False
<$> dataType globalTable typeExpression
parameter :: SymbolTable -> AST.Parameter -> NameAnalysis ParameterInfo
parameter environmentSymbolTable (AST.Parameter identifier typeExpression isReferenceParameter') = do
parameterType <- dataType environmentSymbolTable typeExpression
case parameterType of
ArrayType _ _
| not isReferenceParameter' -> NameAnalysis
$ throwE $ UnexpectedArrayByValue identifier
_ ->
let parameterInfo = ParameterInfo
{ name = identifier
, type' = parameterType
, isReferenceParameter = isReferenceParameter'
}
in pure parameterInfo
dataType :: SymbolTable -> AST.TypeExpression -> NameAnalysis Type
dataType environmentSymbolTable (AST.NamedType baseType) = do
case SymbolTable.lookup baseType environmentSymbolTable of
Just baseInfo
| TypeInfo baseType' <- baseInfo -> pure baseType'
| otherwise -> NameAnalysis $ throwE $ UnexpectedTypeInfoError baseInfo
_ -> NameAnalysis $ throwE $ UndefinedTypeError baseType
dataType environmentSymbolTable (AST.ArrayType arraySize baseType) =
dataType environmentSymbolTable baseType <&> ArrayType (fromIntegral arraySize)
checkSymbol :: SymbolTable -> Identifier -> NameAnalysis ()
checkSymbol globalTable identifier
= unless (SymbolTable.member identifier globalTable)
$ NameAnalysis $ throwE
$ UndefinedSymbolError identifier
expression :: SymbolTable -> AST.Expression -> NameAnalysis ()
expression _ (AST.LiteralExpression _) = pure ()
expression globalTable (AST.SumExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.SubtractionExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.NegationExpression negation) =
expression globalTable negation
expression globalTable (AST.ProductExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.DivisionExpression lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
expression globalTable (AST.VariableExpression variableExpression) =
variableAccess globalTable variableExpression
statement :: SymbolTable -> AST.Statement -> NameAnalysis ()
statement _ AST.EmptyStatement = pure ()
statement globalTable (AST.CallStatement name arguments)
= checkSymbol globalTable name
>> traverse_ (expression globalTable) arguments
statement globalTable (AST.CompoundStatement statements) =
traverse_ (statement globalTable) statements
statement globalTable (AST.IfStatement ifCondition ifStatement elseStatement)
= condition globalTable ifCondition
>> statement globalTable ifStatement
>> maybe (pure ()) (statement globalTable) elseStatement
statement globalTable (AST.AssignmentStatement lvalue rvalue)
= variableAccess globalTable lvalue
>> expression globalTable rvalue
statement globalTable (AST.WhileStatement whileCondition loop)
= condition globalTable whileCondition
>> statement globalTable loop
condition :: SymbolTable -> AST.Condition -> NameAnalysis ()
condition globalTable (AST.EqualCondition lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
condition globalTable (AST.NonEqualCondition lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
condition globalTable (AST.LessCondition lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
condition globalTable (AST.GreaterCondition lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
condition globalTable (AST.LessOrEqualCondition lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
condition globalTable (AST.GreaterOrEqualCondition lhs rhs)
= expression globalTable lhs
>> expression globalTable rhs
variableAccess :: SymbolTable -> AST.VariableAccess -> NameAnalysis ()
variableAccess globalTable (AST.VariableAccess identifier) =
checkSymbol globalTable identifier
variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression)
= variableAccess globalTable arrayExpression
>> expression globalTable indexExpression

227
lib/Language/Elna/Frontend/Parser.hs Normal file
View File

@ -0,0 +1,227 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Frontend.Parser
( Parser
, programP
) where
import Control.Monad (void)
import Control.Monad.Combinators.Expr (Operator(..), makeExprParser)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Void (Void)
import Language.Elna.Frontend.AST
( Declaration(..)
, Identifier(..)
, Parameter(..)
, Program(..)
, Statement(..)
, TypeExpression(..)
, VariableDeclaration(..)
, VariableAccess(..)
, Condition(..)
, Expression(..)
, Literal(..)
)
import Text.Megaparsec
( Parsec
, (<?>)
, MonadParsec(..)
, eof
, optional
, between
, sepBy
, choice
)
import qualified Text.Megaparsec.Char.Lexer as Lexer
import Text.Megaparsec.Char
( alphaNumChar
, char
, letterChar
, space1
, string
)
import Control.Applicative (Alternative(..))
import Data.Maybe (isJust)
type Parser = Parsec Void Text
literalP :: Parser Literal
literalP
= HexadecimalLiteral <$> Lexer.signed space hexadecimalP
<|> DecimalLiteral <$> Lexer.signed space decimalP
<|> CharacterLiteral <$> lexeme charP
where
charP = fromIntegral . fromEnum
<$> between (char '\'') (char '\'') Lexer.charLiteral
typeDefinitionP :: Parser Declaration
typeDefinitionP = TypeDefinition
<$> (symbol "type" *> identifierP)
<*> (symbol "=" *> typeExpressionP)
<* semicolonP
<?> "type definition"
termP :: Parser Expression
termP = choice
[ parensP expressionP
, LiteralExpression <$> literalP
, VariableExpression <$> variableAccessP
]
operatorTable :: [[Operator Parser Expression]]
operatorTable =
[ unaryOperator
, factorOperator
, termOperator
]
where
unaryOperator =
[ prefix "-" NegationExpression
, prefix "+" id
]
factorOperator =
[ binary "*" ProductExpression
, binary "/" DivisionExpression
]
termOperator =
[ binary "+" SumExpression
, binary "-" SubtractionExpression
]
prefix name f = Prefix (f <$ symbol name)
binary name f = InfixL (f <$ symbol name)
expressionP :: Parser Expression
expressionP = makeExprParser termP operatorTable
variableAccessP :: Parser VariableAccess
variableAccessP = do
identifier <- identifierP
indices <- many $ bracketsP expressionP
pure $ foldr (flip ArrayAccess) (VariableAccess identifier) indices
conditionP :: Parser Condition
conditionP = do
lhs <- expressionP
conditionCons <- choice comparisonOperator
conditionCons lhs <$> expressionP
where
comparisonOperator =
[ symbol "<=" >> pure LessOrEqualCondition
, symbol "<" >> pure LessCondition
, symbol ">=" >> pure GreaterOrEqualCondition
, symbol ">" >> pure GreaterCondition
, symbol "=" >> pure EqualCondition
, symbol "#" >> pure NonEqualCondition
]
symbol :: Text -> Parser Text
symbol = Lexer.symbol space
space :: Parser ()
space = Lexer.space space1 (Lexer.skipLineComment "//")
$ Lexer.skipBlockComment "/*" "*/"
lexeme :: forall a. Parser a -> Parser a
lexeme = Lexer.lexeme space
blockP :: forall a. Parser a -> Parser a
blockP = between (symbol "{") (symbol "}")
parensP :: forall a. Parser a -> Parser a
parensP = between (symbol "(") (symbol ")")
bracketsP :: forall a. Parser a -> Parser a
bracketsP = between (symbol "[") (symbol "]")
colonP :: Parser ()
colonP = void $ symbol ":"
commaP :: Parser ()
commaP = void $ symbol ","
semicolonP :: Parser ()
semicolonP = void $ symbol ";"
decimalP :: Integral a => Parser a
decimalP = lexeme Lexer.decimal
hexadecimalP :: Integral a => Parser a
hexadecimalP = string "0x" *> lexeme Lexer.hexadecimal
identifierP :: Parser Identifier
identifierP =
let wordParser = (:) <$> letterChar <*> many alphaNumChar <?> "identifier"
in fmap Identifier $ lexeme $ Text.pack <$> wordParser
procedureP :: Parser ()
procedureP = void $ symbol "proc"
parameterP :: Parser Parameter
parameterP = paramCons
<$> optional (symbol "ref")
<*> identifierP
<*> (colonP *> typeExpressionP)
where
paramCons ref name typeName = Parameter name typeName (isJust ref)
typeExpressionP :: Parser TypeExpression
typeExpressionP = arrayTypeExpression
<|> NamedType <$> identifierP
<?> "type expression"
where
arrayTypeExpression = ArrayType
<$> (symbol "array" *> bracketsP literalP)
<*> (symbol "of" *> typeExpressionP)
procedureDeclarationP :: Parser Declaration
procedureDeclarationP = procedureCons
<$> (procedureP *> identifierP)
<*> parensP (sepBy parameterP commaP)
<*> blockP ((,) <$> many variableDeclarationP <*> many statementP)
<?> "procedure definition"
where
procedureCons procedureName parameters (variables, body) =
ProcedureDeclaration procedureName parameters variables body
statementP :: Parser Statement
statementP
= EmptyStatement <$ semicolonP
<|> ifElseP
<|> CompoundStatement <$> blockP (many statementP)
<|> try assignmentP
<|> try whileP
<|> callP
<?> "statement"
where
callP = CallStatement
<$> identifierP
<*> parensP (sepBy expressionP commaP)
<* semicolonP
ifElseP = IfStatement
<$> (symbol "if" *> parensP conditionP)
<*> statementP
<*> optional (symbol "else" *> statementP)
whileP = WhileStatement
<$> (symbol "while" *> parensP conditionP)
<*> statementP
assignmentP = AssignmentStatement
<$> variableAccessP
<* symbol ":="
<*> expressionP
<* semicolonP
variableDeclarationP :: Parser VariableDeclaration
variableDeclarationP = VariableDeclaration
<$> (symbol "var" *> identifierP)
<*> (colonP *> typeExpressionP)
<* semicolonP
<?> "variable declaration"
declarationP :: Parser Declaration
declarationP = procedureDeclarationP <|> typeDefinitionP
programP :: Parser Program
programP = Program <$> many declarationP <* eof

109
lib/Language/Elna/Frontend/SymbolTable.hs Normal file
View File

@ -0,0 +1,109 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Frontend.SymbolTable
( SymbolTable
, Info(..)
, ParameterInfo(..)
, builtInSymbolTable
, empty
, enter
, fromList
, lookup
, member
, scope
, size
, toMap
, update
) where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List (sort)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (isJust)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Language.Elna.Location (Identifier(..))
import Language.Elna.Frontend.Types (Type(..), intType)
import Prelude hiding (lookup)
data SymbolTable = SymbolTable (Maybe SymbolTable) (HashMap Identifier Info)
deriving (Eq, Show)
empty :: SymbolTable
empty = SymbolTable Nothing HashMap.empty
update :: (Info -> Maybe Info) -> Identifier -> SymbolTable -> SymbolTable
update updater key (SymbolTable parent mappings) = SymbolTable parent
$ HashMap.update updater key mappings
scope :: SymbolTable -> SymbolTable -> SymbolTable
scope parent (SymbolTable _ mappings) = SymbolTable (Just parent) mappings
builtInSymbolTable :: SymbolTable
builtInSymbolTable = SymbolTable Nothing $ HashMap.fromList
[ ("printi", ProcedureInfo empty (Vector.singleton printiX))
, ("printc", ProcedureInfo empty (Vector.singleton printcI))
, ("exit", ProcedureInfo empty Vector.empty)
, ("int", TypeInfo intType)
]
where
printiX = ParameterInfo
{ name = "x"
, type' = intType
, isReferenceParameter = False
}
printcI = ParameterInfo
{ name = "i"
, type' = intType
, isReferenceParameter = False
}
toMap :: SymbolTable -> HashMap Identifier Info
toMap (SymbolTable _ map') = map'
enter :: Identifier -> Info -> SymbolTable -> Maybe SymbolTable
enter identifier info table@(SymbolTable parent hashTable)
| member identifier table = Nothing
| otherwise = Just
$ SymbolTable parent (HashMap.insert identifier info hashTable)
lookup :: Identifier -> SymbolTable -> Maybe Info
lookup identifier (SymbolTable parent table)
| Just found <- HashMap.lookup identifier table = Just found
| Just parent' <- parent = lookup identifier parent'
| otherwise = Nothing
member :: Identifier -> SymbolTable -> Bool
member identifier table =
isJust $ lookup identifier table
size :: SymbolTable -> Int
size (SymbolTable _ map') = HashMap.size map'
fromList :: [(Identifier, Info)] -> Either (NonEmpty Identifier) SymbolTable
fromList elements
| Just identifierDuplicates' <- identifierDuplicates =
Left identifierDuplicates'
| otherwise = Right $ SymbolTable Nothing $ HashMap.fromList elements
where
identifierDuplicates = NonEmpty.nonEmpty
$ fmap NonEmpty.head
$ filter ((> 1) . NonEmpty.length)
$ NonEmpty.group . sort
$ fst <$> elements
data ParameterInfo = ParameterInfo
{ name :: Identifier
, type' :: Type
, isReferenceParameter :: Bool
} deriving (Eq, Show)
data Info
= TypeInfo Type
| VariableInfo Bool Type
| ProcedureInfo SymbolTable (Vector ParameterInfo)
deriving (Eq, Show)

208
lib/Language/Elna/Frontend/TypeAnalysis.hs Normal file
View File

@ -0,0 +1,208 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Frontend.TypeAnalysis
( typeAnalysis
, -- Error(..)
) where
import Control.Applicative (Alternative(..))
import Control.Monad (unless)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except (Except, runExcept, throwE)
import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT, ask, asks)
import Data.Foldable (traverse_)
import qualified Data.Vector as Vector
import qualified Language.Elna.Frontend.AST as AST
import Language.Elna.Frontend.SymbolTable (Info(..), ParameterInfo(..), SymbolTable)
import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
import Language.Elna.Frontend.Types (Type(..), booleanType, intType)
import Language.Elna.Location (Identifier(..))
typeAnalysis :: SymbolTable -> AST.Program -> Maybe Error
typeAnalysis globalTable = either Just (const Nothing)
. runExcept
. flip runReaderT globalTable
. runTypeAnalysis
. program
data Error
= UnexpectedProcedureInfoError Info
| UndefinedSymbolError Identifier
| ParameterCountMismatchError Int Int
| UnexpectedVariableInfoError Info
| ArithmeticExpressionError Type
| ComparisonExpressionError Type Type
| InvalidConditionTypeError Type
{- | ExpectedLvalueError AST.Expression
| ArgumentTypeMismatchError Type Type -}
| ArrayIndexError Type
| ArrayAccessError Type
deriving Eq
instance Show Error
where
show (UnexpectedProcedureInfoError info) =
"Expected to encounter a procedure, got: " <> show info
show (UndefinedSymbolError identifier) =
concat ["Symbol \"", show identifier, "\" is not defined"]
show (ParameterCountMismatchError parameterCount argumentCount)
= "The function was expected to receive " <> show argumentCount
<> " arguments, but got " <> show parameterCount
show (UnexpectedVariableInfoError info) =
"Expected to encounter a variable, got: " <> show info
show (ArithmeticExpressionError got) =
"Expected an arithmetic expression to be an integer, got: " <> show got
show (ComparisonExpressionError lhs rhs)
= "Expected an arithmetic expression to be an integer, got \""
<> show lhs <> "\" and \"" <> show rhs <> "\""
show (InvalidConditionTypeError got) =
"Expected a condition to be a boolean, got: " <> show got
show (ArrayIndexError got) =
"Expected an array index expression to be an integer, got: " <> show got
show (ArrayAccessError got) =
"Expected to encounter an array, got: " <> show got
newtype TypeAnalysis a = TypeAnalysis
{ runTypeAnalysis :: ReaderT SymbolTable (Except Error) a
}
instance Functor TypeAnalysis
where
fmap f (TypeAnalysis x) = TypeAnalysis $ f <$> x
instance Applicative TypeAnalysis
where
pure = TypeAnalysis . pure
(TypeAnalysis f) <*> (TypeAnalysis x) = TypeAnalysis $ f <*> x
instance Monad TypeAnalysis
where
(TypeAnalysis x) >>= f = TypeAnalysis $ x >>= (runTypeAnalysis . f)
program :: AST.Program -> TypeAnalysis ()
program (AST.Program declarations) = traverse_ declaration declarations
declaration :: AST.Declaration -> TypeAnalysis ()
declaration (AST.ProcedureDeclaration procedureName _ _ body) = do
globalTable <- TypeAnalysis ask
case SymbolTable.lookup procedureName globalTable of
Just (ProcedureInfo localTable _) -> TypeAnalysis
$ withReaderT (const localTable)
$ runTypeAnalysis
$ traverse_ (statement globalTable) body
Just anotherInfo -> TypeAnalysis $ lift $ throwE
$ UnexpectedProcedureInfoError anotherInfo
Nothing -> TypeAnalysis $ lift $ throwE
$ UndefinedSymbolError procedureName
declaration (AST.TypeDefinition _ _) = pure ()
statement :: SymbolTable -> AST.Statement -> TypeAnalysis ()
statement globalTable = \case
AST.EmptyStatement -> pure ()
AST.AssignmentStatement lhs rhs -> do
lhsType <- variableAccess globalTable lhs
rhsType <- expression globalTable rhs
unless (lhsType == intType)
$ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError lhsType
unless (rhsType == intType)
$ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError rhsType
AST.WhileStatement whileCondition whileStatement -> do
conditionType <- condition globalTable whileCondition
unless (conditionType == booleanType)
$ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
statement globalTable whileStatement
AST.IfStatement ifCondition ifStatement elseStatement -> do
conditionType <- condition globalTable ifCondition
unless (conditionType == booleanType)
$ TypeAnalysis $ lift $ throwE $ InvalidConditionTypeError conditionType
statement globalTable ifStatement
maybe (pure ()) (statement globalTable) elseStatement
AST.CompoundStatement statements -> traverse_ (statement globalTable) statements
AST.CallStatement procedureName arguments ->
case SymbolTable.lookup procedureName globalTable of
Just (ProcedureInfo _ parameters)
| parametersLength <- Vector.length parameters
, argumentsLength <- length arguments
, Vector.length parameters /= length arguments -> TypeAnalysis $ lift $ throwE
$ ParameterCountMismatchError parametersLength argumentsLength
| otherwise -> traverse_ (uncurry checkArgument)
$ Vector.zip parameters (Vector.fromList arguments)
Just anotherInfo -> TypeAnalysis $ lift $ throwE
$ UnexpectedVariableInfoError anotherInfo
Nothing -> TypeAnalysis $ lift $ throwE
$ UndefinedSymbolError procedureName
where
checkArgument ParameterInfo{} _argument = pure () {-
argumentType <- expression globalTable argument
unless (argumentType == type')
$ TypeAnalysis $ lift $ throwE $ ArgumentTypeMismatchError type' argumentType
when (isReferenceParameter && not (isLvalue argument))
$ TypeAnalysis $ lift $ throwE $ ExpectedLvalueError argument
isLvalue (AST.VariableExpression _) = True
isLvalue _ = False -}
variableAccess :: SymbolTable -> AST.VariableAccess -> TypeAnalysis Type
variableAccess globalTable (AST.VariableAccess identifier) = do
localLookup <- TypeAnalysis $ asks $ SymbolTable.lookup identifier
case localLookup <|> SymbolTable.lookup identifier globalTable of
Just (VariableInfo _ variableType) -> pure variableType
Just anotherInfo -> TypeAnalysis $ lift $ throwE
$ UnexpectedVariableInfoError anotherInfo
Nothing -> TypeAnalysis $ lift $ throwE
$ UndefinedSymbolError identifier
variableAccess globalTable (AST.ArrayAccess arrayExpression indexExpression) = do
arrayType <- variableAccess globalTable arrayExpression
indexType <- expression globalTable indexExpression
unless (indexType == intType)
$ TypeAnalysis $ lift $ throwE $ ArrayIndexError indexType
case arrayType of
ArrayType _ baseType -> pure baseType
nonArrayType -> TypeAnalysis $ lift $ throwE
$ ArrayAccessError nonArrayType
expression :: SymbolTable -> AST.Expression -> TypeAnalysis Type
expression globalTable = \case
AST.VariableExpression variableExpression ->
variableAccess globalTable variableExpression
AST.LiteralExpression literal' -> literal literal'
AST.NegationExpression negation -> do
operandType <- expression globalTable negation
if operandType == intType
then pure intType
else TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError operandType
AST.SumExpression lhs rhs -> arithmeticExpression lhs rhs
AST.SubtractionExpression lhs rhs -> arithmeticExpression lhs rhs
AST.ProductExpression lhs rhs -> arithmeticExpression lhs rhs
AST.DivisionExpression lhs rhs -> arithmeticExpression lhs rhs
where
arithmeticExpression lhs rhs = do
lhsType <- expression globalTable lhs
unless (lhsType == intType)
$ TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError lhsType
rhsType <- expression globalTable rhs
unless (rhsType == intType)
$ TypeAnalysis $ lift $ throwE $ ArithmeticExpressionError rhsType
pure intType
condition :: SymbolTable -> AST.Condition -> TypeAnalysis Type
condition globalTable = \case
AST.EqualCondition lhs rhs -> comparisonExpression lhs rhs
AST.NonEqualCondition lhs rhs -> comparisonExpression lhs rhs
AST.LessCondition lhs rhs -> comparisonExpression lhs rhs
AST.GreaterCondition lhs rhs -> comparisonExpression lhs rhs
AST.LessOrEqualCondition lhs rhs -> comparisonExpression lhs rhs
AST.GreaterOrEqualCondition lhs rhs -> comparisonExpression lhs rhs
where
comparisonExpression lhs rhs = do
lhsType <- expression globalTable lhs
rhsType <- expression globalTable rhs
if lhsType == intType && rhsType == intType
then pure booleanType
else TypeAnalysis $ lift $ throwE $ ComparisonExpressionError lhsType rhsType
literal :: AST.Literal -> TypeAnalysis Type
literal (AST.DecimalLiteral _) = pure intType
literal (AST.HexadecimalLiteral _) = pure intType
literal (AST.CharacterLiteral _) = pure intType

33
lib/Language/Elna/Frontend/Types.hs Normal file
View File

@ -0,0 +1,33 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Frontend.Types
( Type(..)
, addressByteSize
, booleanType
, intType
) where
import Data.Text (Text)
import Data.Word (Word32)
import Language.Elna.Location (showArrayType)
addressByteSize :: Int
addressByteSize = 4
data Type
= PrimitiveType Text Int
| ArrayType Word32 Type
deriving Eq
instance Show Type
where
show (PrimitiveType typeName _) = show typeName
show (ArrayType elementCount typeName) = showArrayType elementCount typeName
intType :: Type
intType = PrimitiveType "int" 4
booleanType :: Type
booleanType = PrimitiveType "boolean" 1

312
lib/Language/Elna/Glue.hs Normal file
View File

@ -0,0 +1,312 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Glue
( glue
) where
import Control.Monad.Trans.State (State, gets, modify', runState)
import Data.Bifunctor (Bifunctor(..))
import Data.Foldable (Foldable(..), traverse_)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (catMaybes)
import Data.Vector (Vector)
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Vector as Vector
import Data.Word (Word32)
import qualified Language.Elna.Frontend.AST as AST
import Language.Elna.Frontend.Types (Type(..))
import Language.Elna.Backend.Intermediate
( Label(..)
, Operand(..)
, Quadruple(..)
, Variable(..)
)
import Language.Elna.Frontend.SymbolTable (Info(..), SymbolTable)
import qualified Language.Elna.Frontend.SymbolTable as SymbolTable
import GHC.Records (HasField(..))
import Language.Elna.Frontend.AST (Identifier(..))
import Debug.Trace (traceShow)
data Paste = Paste
{ temporaryCounter :: Word32
, labelCounter :: Word32
, localMap :: HashMap Identifier Variable
}
newtype Glue a = Glue
{ runGlue :: State Paste a }
instance Functor Glue
where
fmap f (Glue x) = Glue $ f <$> x
instance Applicative Glue
where
pure = Glue . pure
(Glue f) <*> (Glue x) = Glue $ f <*> x
instance Monad Glue
where
(Glue x) >>= f = Glue $ x >>= (runGlue . f)
glue :: SymbolTable -> AST.Program -> HashMap Identifier (Vector (Quadruple Variable))
glue globalTable
= fst
. flip runState emptyPaste
. runGlue
. program globalTable
where
emptyPaste = Paste
{ temporaryCounter = 0
, labelCounter = 0
, localMap = mempty
}
program :: SymbolTable -> AST.Program -> Glue (HashMap Identifier (Vector (Quadruple Variable)))
program globalTable (AST.Program declarations)
= HashMap.fromList . catMaybes
<$> traverse (declaration globalTable) declarations
declaration
:: SymbolTable
-> AST.Declaration
-> Glue (Maybe (AST.Identifier, Vector (Quadruple Variable)))
declaration globalTable (AST.ProcedureDeclaration procedureName parameters variableDeclarations statements) =
let Just (ProcedureInfo localTable _) = SymbolTable.lookup procedureName globalTable
in Glue (modify' resetTemporaryCounter)
>> traverseWithIndex registerVariable variableDeclarations
>> traverseWithIndex registerParameter (reverse parameters)
>> nameQuadruplesTuple <$> traverse (statement localTable) statements
where
traverseWithIndex f = traverse_ (uncurry f) . zip [0..]
registerParameter index (AST.Parameter identifier _ _) =
Glue $ modify' $ modifier identifier $ ParameterVariable index
registerVariable index (AST.VariableDeclaration identifier _) =
Glue $ modify' $ modifier identifier $ LocalVariable index
modifier identifier currentCounter generator = generator
{ localMap = HashMap.insert identifier currentCounter
$ getField @"localMap" generator
}
nameQuadruplesTuple quadrupleList = Just
( procedureName
, Vector.cons StartQuadruple
$ flip Vector.snoc StopQuadruple
$ fold quadrupleList
)
resetTemporaryCounter paste = paste
{ temporaryCounter = 0
, localMap = mempty
}
declaration _ (AST.TypeDefinition _ _) = pure Nothing
statement :: SymbolTable -> AST.Statement -> Glue (Vector (Quadruple Variable))
statement _ AST.EmptyStatement = pure mempty
statement localTable (AST.CallStatement (AST.Identifier callName) arguments) = do
visitedArguments <- traverse (expression localTable) arguments
let (parameterStatements, argumentStatements)
= bimap (Vector.fromList . fmap ParameterQuadruple) Vector.concat
$ unzip visitedArguments
in pure
$ Vector.snoc (argumentStatements <> parameterStatements)
$ CallQuadruple callName
$ fromIntegral
$ length arguments
statement localTable (AST.CompoundStatement statements) =
fold <$> traverse (statement localTable) statements
statement localTable (AST.IfStatement ifCondition ifStatement elseStatement) = do
(conditionStatements, jumpConstructor) <- condition localTable ifCondition
ifLabel <- createLabel
endLabel <- createLabel
ifStatements <- statement localTable ifStatement
possibleElseStatements <- traverse (statement localTable) elseStatement
pure $ conditionStatements <> case possibleElseStatements of
Just elseStatements -> Vector.cons (jumpConstructor ifLabel) elseStatements
<> Vector.fromList [GoToQuadruple endLabel, LabelQuadruple ifLabel]
<> Vector.snoc ifStatements (LabelQuadruple endLabel)
Nothing -> Vector.fromList [jumpConstructor ifLabel, GoToQuadruple endLabel, LabelQuadruple ifLabel]
<> Vector.snoc ifStatements (LabelQuadruple endLabel)
statement localTable (AST.AssignmentStatement variableAccess' assignee) = do
(rhsOperand, rhsStatements) <- expression localTable assignee
let variableType' = variableType variableAccess' localTable
accessResult <- variableAccess localTable variableAccess' Nothing variableType' mempty
lhsStatements <- case accessResult of
(identifier, Just accumulatedIndex, accumulatedStatements)
-> Vector.snoc accumulatedStatements
. ArrayAssignQuadruple rhsOperand accumulatedIndex
<$> lookupLocal identifier
(identifier, Nothing, accumulatedStatements)
-> Vector.snoc accumulatedStatements
. AssignQuadruple rhsOperand
<$> lookupLocal identifier
pure $ rhsStatements <> lhsStatements
statement localTable (AST.WhileStatement whileCondition whileStatement) = do
(conditionStatements, jumpConstructor) <- condition localTable whileCondition
startLabel <- createLabel
endLabel <- createLabel
conditionLabel <- createLabel
whileStatements <- statement localTable whileStatement
pure $ Vector.fromList [LabelQuadruple conditionLabel]
<> conditionStatements
<> Vector.fromList [jumpConstructor startLabel, GoToQuadruple endLabel, LabelQuadruple startLabel]
<> whileStatements
<> Vector.fromList [GoToQuadruple conditionLabel, LabelQuadruple endLabel]
createTemporary :: Glue Variable
createTemporary = do
currentCounter <- Glue $ gets $ getField @"temporaryCounter"
Glue $ modify' modifier
pure $ TempVariable currentCounter
where
modifier generator = generator
{ temporaryCounter = getField @"temporaryCounter" generator + 1
}
lookupLocal :: Identifier -> Glue Variable
lookupLocal identifier =
fmap (HashMap.! identifier) $ Glue $ gets $ getField @"localMap"
createLabel :: Glue Label
createLabel = do
currentCounter <- Glue $ gets $ getField @"labelCounter"
Glue $ modify' modifier
pure $ Label
$ Text.Lazy.toStrict
$ Text.Builder.toLazyText
$ ".L" <> Text.Builder.decimal currentCounter
where
modifier generator = generator
{ labelCounter = getField @"labelCounter" generator + 1
}
condition
:: SymbolTable
-> AST.Condition
-> Glue (Vector (Quadruple Variable), Label -> Quadruple Variable)
condition localTable (AST.EqualCondition lhs rhs) = do
(lhsOperand, lhsStatements) <- expression localTable lhs
(rhsOperand, rhsStatements) <- expression localTable rhs
pure
( lhsStatements <> rhsStatements
, EqualQuadruple lhsOperand rhsOperand
)
condition localTable (AST.NonEqualCondition lhs rhs) = do
(lhsOperand, lhsStatements) <- expression localTable lhs
(rhsOperand, rhsStatements) <- expression localTable rhs
pure
( lhsStatements <> rhsStatements
, NonEqualQuadruple lhsOperand rhsOperand
)
condition localTable (AST.LessCondition lhs rhs) = do
(lhsOperand, lhsStatements) <- expression localTable lhs
(rhsOperand, rhsStatements) <- expression localTable rhs
pure (lhsStatements <> rhsStatements, LessQuadruple lhsOperand rhsOperand)
condition localTable (AST.GreaterCondition lhs rhs) = do
(lhsOperand, lhsStatements) <- expression localTable lhs
(rhsOperand, rhsStatements) <- expression localTable rhs
pure
( lhsStatements <> rhsStatements
, GreaterQuadruple lhsOperand rhsOperand
)
condition localTable (AST.LessOrEqualCondition lhs rhs) = do
(lhsOperand, lhsStatements) <- expression localTable lhs
(rhsOperand, rhsStatements) <- expression localTable rhs
pure
( lhsStatements <> rhsStatements
, LessOrEqualQuadruple lhsOperand rhsOperand
)
condition localTable (AST.GreaterOrEqualCondition lhs rhs) = do
(lhsOperand, lhsStatements) <- expression localTable lhs
(rhsOperand, rhsStatements) <- expression localTable rhs
pure
( lhsStatements <> rhsStatements
, GreaterOrEqualQuadruple lhsOperand rhsOperand
)
variableAccess
:: SymbolTable
-> AST.VariableAccess
-> Maybe (Operand Variable)
-> Type
-> Vector (Quadruple Variable)
-> Glue (AST.Identifier, Maybe (Operand Variable), Vector (Quadruple Variable))
variableAccess _ (AST.VariableAccess identifier) accumulatedIndex _ accumulatedStatements =
pure (identifier, accumulatedIndex, accumulatedStatements)
variableAccess localTable accessKind accumulatedIndex arrayType statements
| (AST.ArrayAccess access1 index1) <- accessKind
, (ArrayType arraySize baseType) <- arrayType = do
(indexPlace, statements') <- expression localTable index1
case accumulatedIndex of
Just baseIndex -> do
resultVariable <- createTemporary
let resultOperand = VariableOperand resultVariable
indexCalculation = Vector.fromList
[ ProductQuadruple (IntOperand $ fromIntegral arraySize) baseIndex resultVariable
, AddQuadruple indexPlace resultOperand resultVariable
]
in variableAccess localTable access1 (Just resultOperand) baseType
$ statements <> indexCalculation <> statements'
Nothing ->
variableAccess localTable access1 (Just indexPlace) baseType statements'
variableAccess _ _ _ _ _ = error "Array access operator doesn't match the type."
variableType :: AST.VariableAccess -> SymbolTable -> Type
variableType (AST.VariableAccess identifier) symbolTable
| Just (TypeInfo type') <- SymbolTable.lookup identifier symbolTable = type'
| Just (VariableInfo _ type') <- SymbolTable.lookup identifier symbolTable = type'
| otherwise = traceShow identifier $ error "Undefined type."
variableType (AST.ArrayAccess arrayAccess' _) symbolTable =
variableType arrayAccess' symbolTable
expression :: SymbolTable -> AST.Expression -> Glue (Operand Variable, Vector (Quadruple Variable))
expression localTable = \case
(AST.LiteralExpression literal') -> pure (literal literal', mempty)
(AST.SumExpression lhs rhs) -> binaryExpression AddQuadruple lhs rhs
(AST.SubtractionExpression lhs rhs) ->
binaryExpression SubtractionQuadruple lhs rhs
(AST.NegationExpression negation) -> do
(operand, statements) <- expression localTable negation
tempVariable <- createTemporary
let negationQuadruple = NegationQuadruple operand tempVariable
pure
( VariableOperand tempVariable
, Vector.snoc statements negationQuadruple
)
(AST.ProductExpression lhs rhs) ->
binaryExpression ProductQuadruple lhs rhs
(AST.DivisionExpression lhs rhs) ->
binaryExpression DivisionQuadruple lhs rhs
(AST.VariableExpression variableExpression) -> do
let variableType' = variableType variableExpression localTable
variableAccess' <- variableAccess localTable variableExpression Nothing variableType' mempty
case variableAccess' of
(identifier, Nothing, statements)
-> (, statements) . VariableOperand
<$> lookupLocal identifier
(identifier, Just operand, statements) -> do
arrayAddress <- createTemporary
localVariable <- lookupLocal identifier
let arrayStatement = ArrayQuadruple localVariable operand arrayAddress
pure
( VariableOperand arrayAddress
, Vector.snoc statements arrayStatement
)
where
binaryExpression f lhs rhs = do
(lhsOperand, lhsStatements) <- expression localTable lhs
(rhsOperand, rhsStatements) <- expression localTable rhs
tempVariable <- createTemporary
let newQuadruple = f lhsOperand rhsOperand tempVariable
pure
( VariableOperand tempVariable
, Vector.snoc (lhsStatements <> rhsStatements) newQuadruple
)
literal :: AST.Literal -> Operand Variable
literal (AST.DecimalLiteral integer) = IntOperand integer
literal (AST.HexadecimalLiteral integer) = IntOperand integer
literal (AST.CharacterLiteral character) = IntOperand $ fromIntegral character

62
lib/Language/Elna/Location.hs Normal file
View File

@ -0,0 +1,62 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Location
( Identifier(..)
, Location(..)
, Node(..)
, showArrayType
) where
import Data.Hashable (Hashable(..))
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Word (Word32)
data Location = Location
{ line :: Word32
, column :: Word32
} deriving (Eq, Show)
instance Semigroup Location
where
(Location thisLine thisColumn) <> (Location thatLine thatColumn) = Location
{ line = thisLine + thatLine
, column = thisColumn + thatColumn
}
instance Monoid Location
where
mempty = Location{ line = 1, column = 1 }
data Node a = Node a Location
deriving (Eq, Show)
instance Functor Node
where
fmap f (Node node location) = Node (f node) location
newtype Identifier = Identifier { unIdentifier :: Text }
deriving Eq
instance Show Identifier
where
show (Identifier identifier) = Text.unpack identifier
instance IsString Identifier
where
fromString = Identifier . Text.pack
instance Ord Identifier
where
compare (Identifier lhs) (Identifier rhs) = compare lhs rhs
instance Hashable Identifier
where
hashWithSalt salt (Identifier identifier) = hashWithSalt salt identifier
showArrayType :: (Show a, Show b) => a -> b -> String
showArrayType elementCount typeName = concat
["array[", show elementCount, "] of ", show typeName]

492
lib/Language/Elna/Object/Elf.hs Normal file
View File

@ -0,0 +1,492 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Object.Elf
( ByteOrder(..)
, Elf32_Addr
, Elf32_Off
, Elf32_Half
, Elf32_Word
, Elf32_Sword
, Elf32_Ehdr(..)
, Elf32_Rel(..)
, Elf32_Rela(..)
, Elf32_Shdr(..)
, Elf32_Sym(..)
, ElfEncodingError(..)
, ElfIdentification(..)
, ElfMachine(..)
, ElfVersion(..)
, ElfClass(..)
, ElfData(..)
, ElfType(..)
, ElfSectionType(..)
, ElfSymbolBinding(..)
, ElfSymbolType(..)
, byteOrder
, elf32Addr
, elf32Half
, elf32Off
, elf32Shdr
, elf32Sword
, elf32Word
, elf32Ehdr
, elf32Rel
, elf32Rela
, elf32Sym
, elfIdentification
, rInfo
, shfWrite
, shfAlloc
, shfExecinstr
, shfMascproc
, shfInfoLink
, stInfo
) where
import Control.Exception (Exception(..))
import Data.Bits (Bits(..))
import qualified Data.ByteString.Builder as ByteString.Builder
import Data.Int (Int32)
import Data.Word (Word8, Word16, Word32)
import qualified Data.ByteString as ByteString
-- * Data types.
type Elf32_Addr = Word32 -- ^ Unsigned program address.
type Elf32_Half = Word16 -- ^ Unsigned medium integer.
type Elf32_Off = Word32 -- ^ Unsigned file offset.
type Elf32_Sword = Int32 -- ^ Signed large integer.
type Elf32_Word = Word32 -- ^ Unsigned large integer.
data ElfClass
= ELFCLASSNONE -- ^ Invalid class.
| ELFCLASS32 -- ^ 32-bit objects.
| ELFCLASS64 -- ^ 64-bit objects.
deriving Eq
instance Show ElfClass
where
show ELFCLASSNONE = "ELFCLASSNONE"
show ELFCLASS32 = "ELFCLASS32"
show ELFCLASS64 = "ELFCLASS64"
instance Enum ElfClass
where
toEnum 0 = ELFCLASSNONE
toEnum 1 = ELFCLASS32
toEnum 2 = ELFCLASS64
toEnum _ = error "Unknown Elf class"
fromEnum ELFCLASSNONE = 0
fromEnum ELFCLASS32 = 1
fromEnum ELFCLASS64 = 1
-- | Data encoding.
data ElfData
= ELFDATANONE
| ELFDATA2LSB
| ELFDATA2MSB
deriving Eq
instance Show ElfData
where
show ELFDATANONE = "ELFDATANONE"
show ELFDATA2LSB = "ELFDATA2LSB"
show ELFDATA2MSB = "ELFDATA2MSB"
instance Enum ElfData
where
toEnum 0 = ELFDATANONE
toEnum 1 = ELFDATA2LSB
toEnum 2 = ELFDATA2MSB
toEnum _ = error "Unknown elf data"
fromEnum ELFDATANONE = 0
fromEnum ELFDATA2LSB = 1
fromEnum ELFDATA2MSB = 2
data ElfIdentification = ElfIdentification ElfClass ElfData
deriving Eq
-- | ELF header.
data Elf32_Ehdr = Elf32_Ehdr
{ e_ident :: ElfIdentification
, e_type :: ElfType
, e_machine :: ElfMachine
, e_version :: ElfVersion
, e_entry :: Elf32_Addr
, e_phoff :: Elf32_Off
, e_shoff :: Elf32_Off
, e_flags :: Elf32_Word
, e_ehsize :: Elf32_Half
, e_phentsize :: Elf32_Half
, e_phnum :: Elf32_Half
, e_shentsize :: Elf32_Half
, e_shnum :: Elf32_Half
, e_shstrndx :: Elf32_Half
} deriving Eq
-- | Section header.
data Elf32_Shdr = Elf32_Shdr
{ sh_name :: Elf32_Word
, sh_type :: ElfSectionType
, sh_flags :: Elf32_Word
, sh_addr :: Elf32_Addr
, sh_offset :: Elf32_Off
, sh_size :: Elf32_Word
, sh_link :: Elf32_Word
, sh_info :: Elf32_Word
, sh_addralign :: Elf32_Word
, sh_entsize :: Elf32_Word
} deriving Eq
data ElfMachine
= ElfMachine Elf32_Half
| EM_NONE -- ^ No machine.
| EM_M32 -- ^ AT&T WE 32100.
| EM_SPARC -- ^ SPARC.
| EM_386 -- ^ Intel Architecture.
| EM_68K -- ^ Motorola 68000.
| EM_88K -- ^ Motorola 88000.
| EM_860 -- ^ Intel 80860.
| EM_MIPS -- ^ MIPS RS3000 Big-Endian.
| EM_MIPS_RS4_BE -- ^ MIPS RS4000 Big-Endian.
| EM_RISCV -- ^ RISC-V.
deriving Eq
instance Enum ElfMachine
where
toEnum 0x0 = EM_NONE
toEnum 0x1 = EM_M32
toEnum 0x2 = EM_SPARC
toEnum 0x3 = EM_386
toEnum 0x4 = EM_68K
toEnum 0x5 = EM_88K
toEnum 0x7 = EM_860
toEnum 0x8 = EM_MIPS
toEnum 0xa = EM_MIPS_RS4_BE
toEnum 0xf3 = EM_RISCV
toEnum x = ElfMachine $ fromIntegral x
fromEnum EM_NONE = 0x0
fromEnum EM_M32 = 0x1
fromEnum EM_SPARC = 0x2
fromEnum EM_386 = 0x3
fromEnum EM_68K = 0x4
fromEnum EM_88K = 0x5
fromEnum EM_860 = 0x7
fromEnum EM_MIPS = 0x8
fromEnum EM_MIPS_RS4_BE = 0xa
fromEnum EM_RISCV = 0xf3
fromEnum (ElfMachine x) = fromIntegral x
data ElfVersion
= ElfVersion Elf32_Word
| EV_NONE -- ^ Invalid versionn.
| EV_CURRENT -- ^ Current version.
deriving Eq
instance Enum ElfVersion
where
toEnum 0 = EV_NONE
toEnum 1 = EV_CURRENT
toEnum x = ElfVersion $ fromIntegral x
fromEnum EV_NONE = 0
fromEnum EV_CURRENT = 1
fromEnum (ElfVersion x) = fromIntegral x
data ElfType
= ElfType Elf32_Half
| ET_NONE -- ^ No file type.
| ET_REL -- ^ Relocatable file.
| ET_EXEC -- ^ Executable file.
| ET_DYN -- ^ Shared object file.
| ET_CORE -- ^ Core file.
| ET_LOPROC -- ^ Processor-specific.
| ET_HIPROC -- ^ Processor-specific.
deriving Eq
instance Enum ElfType
where
toEnum 0 = ET_NONE
toEnum 1 = ET_REL
toEnum 2 = ET_EXEC
toEnum 3 = ET_DYN
toEnum 4 = ET_CORE
toEnum 0xff00 = ET_LOPROC
toEnum 0xffff = ET_HIPROC
toEnum x = ElfType $ fromIntegral x
fromEnum ET_NONE = 0
fromEnum ET_REL = 1
fromEnum ET_EXEC = 2
fromEnum ET_DYN = 3
fromEnum ET_CORE = 4
fromEnum ET_LOPROC = 0xff00
fromEnum ET_HIPROC = 0xffff
fromEnum (ElfType x) = fromIntegral x
data Elf32_Sym = Elf32_Sym
{ st_name :: Elf32_Word
, st_value :: Elf32_Addr
, st_size :: Elf32_Word
, st_info :: Word8
, st_other :: Word8
, st_shndx :: Elf32_Half
} deriving Eq
data ElfSymbolBinding
= ElfSymbolBinding Word8
| STB_LOCAL
| STB_GLOBAL
| STB_WEAK
| STB_LOPROC
| STB_HIPROC
deriving Eq
instance Enum ElfSymbolBinding
where
toEnum 0 = STB_LOCAL
toEnum 1 = STB_GLOBAL
toEnum 2 = STB_WEAK
toEnum 13 = STB_LOPROC
toEnum 15 = STB_HIPROC
toEnum x = ElfSymbolBinding $ fromIntegral x
fromEnum STB_LOCAL = 0
fromEnum STB_GLOBAL = 1
fromEnum STB_WEAK = 2
fromEnum STB_LOPROC = 13
fromEnum STB_HIPROC = 15
fromEnum (ElfSymbolBinding x) = fromIntegral x
data ElfSymbolType
= ElfSymbolType Word8
| STT_NOTYPE
| STT_OBJECT
| STT_FUNC
| STT_SECTION
| STT_FILE
| STT_LOPROC
| STT_HIPROC
deriving Eq
instance Enum ElfSymbolType
where
toEnum 0 = STT_NOTYPE
toEnum 1 = STT_OBJECT
toEnum 2 = STT_FUNC
toEnum 3 = STT_SECTION
toEnum 4 = STT_FILE
toEnum 13 = STT_LOPROC
toEnum 15 = STT_HIPROC
toEnum x = ElfSymbolType $ fromIntegral x
fromEnum STT_NOTYPE = 0
fromEnum STT_OBJECT = 1
fromEnum STT_FUNC = 2
fromEnum STT_SECTION = 3
fromEnum STT_FILE = 4
fromEnum STT_LOPROC = 13
fromEnum STT_HIPROC = 15
fromEnum (ElfSymbolType x) = fromIntegral x
data Elf32_Rel = Elf32_Rel
{ r_offset :: Elf32_Addr
, r_info :: Elf32_Word
} deriving Eq
data Elf32_Rela = Elf32_Rela
{ r_offset :: Elf32_Addr
, r_info :: Elf32_Word
, r_addend :: Elf32_Sword
} deriving Eq
data ElfSectionType
= ElfSectionType Elf32_Word
| SHT_NULL
| SHT_PROGBITS
| SHT_SYMTAB
| SHT_STRTAB
| SHT_RELA
| SHT_HASH
| SHT_DYNAMIC
| SHT_NOTE
| SHT_NOBITS
| SHT_REL
| SHT_SHLIB
| SHT_DYNSYM
| SHT_LOPROC
| SHT_HIPROC
| SHT_LOUSER
| SHT_HIUSER
deriving Eq
instance Enum ElfSectionType
where
toEnum 0 = SHT_NULL
toEnum 1 = SHT_PROGBITS
toEnum 2 = SHT_SYMTAB
toEnum 3 = SHT_STRTAB
toEnum 4 = SHT_RELA
toEnum 5 = SHT_HASH
toEnum 6 = SHT_DYNAMIC
toEnum 7 = SHT_NOTE
toEnum 8 = SHT_NOBITS
toEnum 9 = SHT_REL
toEnum 10 = SHT_SHLIB
toEnum 11 = SHT_DYNSYM
toEnum 0x70000000 = SHT_LOPROC
toEnum 0x7fffffff = SHT_HIPROC
toEnum 0x80000000 = SHT_LOUSER
toEnum 0xffffffff = SHT_HIUSER
toEnum x = ElfSectionType $ fromIntegral x
fromEnum SHT_NULL = 0
fromEnum SHT_PROGBITS = 1
fromEnum SHT_SYMTAB = 2
fromEnum SHT_STRTAB = 3
fromEnum SHT_RELA = 4
fromEnum SHT_HASH = 5
fromEnum SHT_DYNAMIC = 6
fromEnum SHT_NOTE = 7
fromEnum SHT_NOBITS = 8
fromEnum SHT_REL = 9
fromEnum SHT_SHLIB = 10
fromEnum SHT_DYNSYM = 11
fromEnum SHT_LOPROC = 0x70000000
fromEnum SHT_HIPROC = 0x7fffffff
fromEnum SHT_LOUSER = 0x80000000
fromEnum SHT_HIUSER = 0xffffffff
fromEnum (ElfSectionType x) = fromIntegral x
-- * Constants.
shfWrite :: Elf32_Word
shfWrite = 0x1
shfAlloc :: Elf32_Word
shfAlloc = 0x2
shfExecinstr:: Elf32_Word
shfExecinstr = 0x4
shfMascproc :: Elf32_Word
shfMascproc = 0xf0000000
shfInfoLink :: Elf32_Word
shfInfoLink = 0x40
-- * Encoding functions.
elf32Addr :: ByteOrder -> Elf32_Addr -> ByteString.Builder.Builder
elf32Addr LSB = ByteString.Builder.word32LE
elf32Addr MSB = ByteString.Builder.word32BE
elf32Half :: ByteOrder -> Elf32_Half -> ByteString.Builder.Builder
elf32Half LSB = ByteString.Builder.word16LE
elf32Half MSB = ByteString.Builder.word16BE
elf32Off :: ByteOrder -> Elf32_Off -> ByteString.Builder.Builder
elf32Off LSB = ByteString.Builder.word32LE
elf32Off MSB = ByteString.Builder.word32BE
elf32Sword :: ByteOrder -> Elf32_Sword -> ByteString.Builder.Builder
elf32Sword LSB = ByteString.Builder.int32LE
elf32Sword MSB = ByteString.Builder.int32BE
elf32Word :: ByteOrder -> Elf32_Word -> ByteString.Builder.Builder
elf32Word LSB = ByteString.Builder.word32LE
elf32Word MSB = ByteString.Builder.word32BE
elfIdentification :: ElfIdentification -> ByteString.Builder.Builder
elfIdentification (ElfIdentification elfClass elfData)
= ByteString.Builder.word8 0x7f
<> ByteString.Builder.string7 "ELF"
<> ByteString.Builder.word8 (fromIntegralEnum elfClass)
<> ByteString.Builder.word8 (fromIntegralEnum elfData)
<> ByteString.Builder.word8 (fromIntegralEnum EV_CURRENT)
<> ByteString.Builder.byteString (ByteString.replicate 9 0)
elf32Ehdr :: Elf32_Ehdr -> Either ElfEncodingError ByteString.Builder.Builder
elf32Ehdr Elf32_Ehdr{..} = encode <$> byteOrder e_ident
where
encode byteOrder'
= elfIdentification e_ident
<> elf32Half byteOrder' (fromIntegralEnum e_type)
<> elf32Half byteOrder' (fromIntegralEnum e_machine)
<> elf32Word byteOrder' (fromIntegralEnum e_version)
<> elf32Addr byteOrder' e_entry
<> elf32Off byteOrder' e_phoff
<> elf32Off byteOrder' e_shoff
<> elf32Word byteOrder' e_flags
<> elf32Half byteOrder' e_ehsize
<> elf32Half byteOrder' e_phentsize
<> elf32Half byteOrder' e_phnum
<> elf32Half byteOrder' e_shentsize
<> elf32Half byteOrder' e_shnum
<> elf32Half byteOrder' e_shstrndx
byteOrder :: ElfIdentification -> Either ElfEncodingError ByteOrder
byteOrder (ElfIdentification class' _)
| class' /= ELFCLASS32 = Left $ ElfUnsupportedClassError class'
byteOrder (ElfIdentification _ ELFDATA2MSB) = Right MSB
byteOrder (ElfIdentification _ ELFDATA2LSB) = Right LSB
byteOrder (ElfIdentification _ ELFDATANONE) = Left ElfInvalidByteOrderError
elf32Shdr :: ByteOrder -> Elf32_Shdr -> ByteString.Builder.Builder
elf32Shdr byteOrder' Elf32_Shdr{..}
= elf32Word byteOrder' sh_name
<> elf32Word byteOrder' (fromIntegralEnum sh_type)
<> elf32Word byteOrder' sh_flags
<> elf32Addr byteOrder' sh_addr
<> elf32Off byteOrder' sh_offset
<> elf32Word byteOrder' sh_size
<> elf32Word byteOrder' sh_link
<> elf32Word byteOrder' sh_info
<> elf32Word byteOrder' sh_addralign
<> elf32Word byteOrder' sh_entsize
elf32Sym :: ByteOrder -> Elf32_Sym -> ByteString.Builder.Builder
elf32Sym byteOrder' Elf32_Sym{..}
= elf32Word byteOrder' st_name
<> elf32Addr byteOrder' st_value
<> elf32Word byteOrder' st_size
<> ByteString.Builder.word8 st_info
<> ByteString.Builder.word8 st_other
<> elf32Half byteOrder' st_shndx
elf32Rel :: ByteOrder -> Elf32_Rel -> ByteString.Builder.Builder
elf32Rel byteOrder' Elf32_Rel{..}
= elf32Addr byteOrder' r_offset
<> elf32Word byteOrder' r_info
elf32Rela :: ByteOrder -> Elf32_Rela -> ByteString.Builder.Builder
elf32Rela byteOrder' Elf32_Rela{..}
= elf32Addr byteOrder' r_offset
<> elf32Word byteOrder' r_info
<> elf32Sword byteOrder' r_addend
stInfo :: ElfSymbolBinding -> ElfSymbolType -> Word8
stInfo binding type' = fromIntegralEnum binding `shiftL` 4
.|. (fromIntegralEnum type' .&. 0xf)
rInfo :: Elf32_Word -> Word8 -> Elf32_Word
rInfo symbol type' = symbol `shiftL` 8
.|. fromIntegralEnum type'
-- * Help types and functions.
data ByteOrder = LSB | MSB
deriving Eq
data ElfEncodingError
= ElfInvalidByteOrderError
| ElfUnsupportedClassError ElfClass
deriving Eq
instance Show ElfEncodingError
where
show ElfInvalidByteOrderError = "Invalid byte order."
show (ElfUnsupportedClassError class') =
concat ["Elf class \"", show class', "\" is not supported."]
instance Exception ElfEncodingError
fromIntegralEnum :: (Enum a, Num b) => a -> b
fromIntegralEnum = fromIntegral . fromEnum

148
lib/Language/Elna/Object/ElfCoder.hs Normal file
View File

@ -0,0 +1,148 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
-- | Object file generation.
module Language.Elna.Object.ElfCoder
( ElfEnvironment(..)
, ElfWriter(..)
, ElfHeaderResult(..)
, UnresolvedRelocation(..)
, UnresolvedRelocations(..)
, addHeaderToResult
, addSectionHeader
, elfHeaderSize
, elfObject
, elfSectionsSize
, putSectionHeader
, partitionSymbols
, module Language.Elna.Object.Elf
) where
import Control.Exception (throwIO)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.State (StateT, runStateT, modify', gets)
import Data.Bits (Bits(..))
import Data.ByteString (StrictByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Builder as ByteString.Builder
import Data.Word (Word8)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import System.IO (Handle, IOMode(..), SeekMode(..), hSeek, withFile)
import Data.Foldable (traverse_)
import Language.Elna.Object.Elf
import Language.Elna.Object.StringTable (StringTable)
import qualified Language.Elna.Object.StringTable as StringTable
import GHC.Records (HasField(..))
data UnresolvedRelocation = UnresolvedRelocation StrictByteString Elf32_Addr Word8
data UnresolvedRelocations =
UnresolvedRelocations (Vector UnresolvedRelocation) (ElfHeaderResult Elf32_Sym) Elf32_Word
data ElfEnvironment = ElfEnvironment
{ objectHeaders :: ElfHeaderResult Elf32_Shdr
, objectHandle :: Handle
}
newtype ElfWriter a = ElfWriter
{ runElfWriter :: StateT ElfEnvironment IO a
}
data ElfHeaderResult a = ElfHeaderResult
{ sectionNames :: StringTable
, sectionHeaders :: Vector a
} deriving Eq
instance Functor ElfWriter
where
fmap f (ElfWriter x) = ElfWriter $ f <$> x
instance Applicative ElfWriter
where
pure = ElfWriter . pure
(ElfWriter f) <*> (ElfWriter x) = ElfWriter $ f <*> x
instance Monad ElfWriter
where
(ElfWriter x) >>= f = ElfWriter $ x >>= (runElfWriter . f)
instance MonadIO ElfWriter
where
liftIO = ElfWriter . liftIO
partitionSymbols :: ElfHeaderResult Elf32_Sym -> (Vector Elf32_Sym, Vector Elf32_Sym)
partitionSymbols = Vector.partition go . getField @"sectionHeaders"
where
go Elf32_Sym{ st_info } = (st_info .&. 0xf0) == 0
-- | ELF header size.
elfHeaderSize :: Elf32_Off
elfHeaderSize = 52
-- | Calculates the size of all sections based on the 'sh_size' in the given
-- headers and adds 'elfHeaderSize' to it.
elfSectionsSize :: Vector Elf32_Shdr -> Elf32_Off
elfSectionsSize = (elfHeaderSize +)
. Vector.foldr ((+) . sh_size) 0
addHeaderToResult :: StrictByteString -> a -> ElfHeaderResult a -> ElfHeaderResult a
addHeaderToResult name newHeader accumulator@ElfHeaderResult{..} = accumulator
{ sectionHeaders = Vector.snoc sectionHeaders newHeader
, sectionNames = StringTable.append name sectionNames
}
addSectionHeader :: StrictByteString -> Elf32_Shdr -> ElfWriter ()
addSectionHeader name newHeader = ElfWriter $ modify' modifier
where
modifier elfEnvironment@ElfEnvironment{ objectHeaders } = elfEnvironment
{ objectHeaders = addHeaderToResult name newHeader objectHeaders
}
putSectionHeader :: StrictByteString -> Elf32_Shdr -> StrictByteString -> ElfWriter ()
putSectionHeader name newHeader encoded = do
objectHandle' <- ElfWriter $ gets $ getField @"objectHandle"
liftIO $ ByteString.hPut objectHandle' encoded
addSectionHeader name newHeader
-- Writes an ELF object to the provided file path. The callback writes the
-- sections, collects headers for those sections and returns the ELF header.
elfObject :: FilePath -> ElfWriter Elf32_Ehdr -> IO ()
elfObject outFile putContents = withFile outFile WriteMode withObjectFile
where
withObjectFile objectHandle
= hSeek objectHandle AbsoluteSeek (fromIntegral elfHeaderSize)
>> putContents' objectHandle
>>= uncurry afterContents
putContents' objectHandle
= flip runStateT (initialState objectHandle)
$ runElfWriter putContents
zeroHeader = Elf32_Shdr
{ sh_type = SHT_NULL
, sh_size = 0
, sh_offset = 0
, sh_name = 0
, sh_link = 0
, sh_info = 0
, sh_flags = 0
, sh_entsize = 0
, sh_addralign = 0
, sh_addr = 0
}
initialState objectHandle = ElfEnvironment
{ objectHeaders = ElfHeaderResult
{ sectionHeaders = Vector.singleton zeroHeader
, sectionNames = mempty
}
, objectHandle = objectHandle
}
afterContents header ElfEnvironment{ objectHeaders = ElfHeaderResult{..}, ..} =
let hPutBuilder = ByteString.Builder.hPutBuilder objectHandle
writeSectionHeaders byteOrder' =
traverse_ (hPutBuilder . elf32Shdr byteOrder') sectionHeaders
in either throwIO pure (byteOrder (e_ident header))
>>= writeSectionHeaders
>> either throwIO (putHeaders objectHandle) (elf32Ehdr header)
putHeaders objectHandle encodedHeader
= hSeek objectHandle AbsoluteSeek 0
>> ByteString.Builder.hPutBuilder objectHandle encodedHeader

48
lib/Language/Elna/Object/StringTable.hs Normal file
View File

@ -0,0 +1,48 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.Object.StringTable
( StringTable
, append
, elem
, index
, encode
, size
) where
import Data.ByteString (StrictByteString)
import qualified Data.ByteString as ByteString
import Language.Elna.Object.Elf
import Prelude hiding (elem)
newtype StringTable = StringTable StrictByteString
deriving Eq
instance Semigroup StringTable
where
(StringTable x) <> (StringTable y) = StringTable $ x <> ByteString.drop 1 y
instance Monoid StringTable
where
mempty = StringTable "\0"
size :: StringTable -> Elf32_Word
size (StringTable container) =
fromIntegral $ ByteString.length container
elem :: StrictByteString -> StringTable -> Bool
elem needle (StringTable container) =
("\0" <> needle <> "\0") `ByteString.isInfixOf` container
append :: StrictByteString -> StringTable -> StringTable
append element (StringTable container) =
StringTable $ container <> element <> "\0"
index :: Elf32_Word -> StringTable -> StrictByteString
index stringTableIndex (StringTable stringTable)
= ByteString.takeWhile (/= 0)
$ ByteString.drop (fromIntegral stringTableIndex) stringTable
encode :: StringTable -> StrictByteString
encode (StringTable container) = container

519
lib/Language/Elna/RiscV/CodeGenerator.hs Normal file
View File

@ -0,0 +1,519 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.RiscV.CodeGenerator
( Directive(..)
, Statement(..)
, generateRiscV
, riscVConfiguration
) where
import Control.Monad.Trans.State (State, get, evalState, modify')
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Int (Int32)
import Data.Word (Word32)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import qualified Language.Elna.Architecture.RiscV as RiscV
import Language.Elna.Backend.Allocator (MachineConfiguration(..), Store(..))
import Language.Elna.Backend.Intermediate
( Label(..)
, Operand(..)
, ProcedureQuadruples(..)
, Quadruple(..)
)
import Language.Elna.Location (Identifier(..))
import Data.Bits (Bits(..))
import Data.Foldable (Foldable(..), foldlM)
import Data.Text (Text)
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Text.Lazy as Text.Lazy
data Directive
= GlobalDirective
| FunctionDirective
deriving (Eq, Show)
data Statement
= Instruction RiscV.Instruction
| JumpLabel Text [Directive]
deriving Eq
riscVConfiguration :: MachineConfiguration RiscV.XRegister
riscVConfiguration = MachineConfiguration
{ temporaryRegisters =
[ RiscV.T0
, RiscV.T1
, RiscV.T2
, RiscV.T3
, RiscV.T4
, RiscV.T5
, RiscV.T6
]
}
-- | Reserved register used for calculations to save an immediate temporary.
immediateRegister :: RiscV.XRegister
immediateRegister = RiscV.A7
type RiscVStore = Store RiscV.XRegister
type RiscVQuadruple = Quadruple RiscVStore
type RiscVOperand = Operand RiscVStore
newtype RiscVGenerator a = RiscVGenerator
{ runRiscVGenerator :: State Word32 a }
instance Functor RiscVGenerator
where
fmap f (RiscVGenerator x) = RiscVGenerator $ f <$> x
instance Applicative RiscVGenerator
where
pure = RiscVGenerator . pure
(RiscVGenerator f) <*> (RiscVGenerator x) = RiscVGenerator $ f <*> x
instance Monad RiscVGenerator
where
(RiscVGenerator x) >>= f = RiscVGenerator $ x >>= (runRiscVGenerator . f)
createLabel :: RiscVGenerator Text
createLabel = do
currentCounter <- RiscVGenerator get
RiscVGenerator $ modify' (+ 1)
pure
$ mappend ".A"
$ Text.Lazy.toStrict
$ Text.Builder.toLazyText
$ Text.Builder.decimal currentCounter
generateRiscV :: HashMap Identifier (ProcedureQuadruples RiscVStore) -> Vector Statement
generateRiscV = flip evalState 0
. runRiscVGenerator
. foldlM go Vector.empty
. HashMap.toList
where
go accumulator (Identifier key, ProcedureQuadruples{ stackSize, quadruples = value }) =
let code = Vector.cons (JumpLabel key [GlobalDirective, FunctionDirective])
. fold <$> mapM (quadruple stackSize) value
in (accumulator <>) <$> code
quadruple :: Word32 -> RiscVQuadruple -> RiscVGenerator (Vector Statement)
quadruple stackSize StartQuadruple =
let totalStackSize = stackSize + 8
in pure $ Vector.fromList
[ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate totalStackSize))
, Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP RiscV.S0)
, Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 4 RiscV.SW RiscV.SP RiscV.RA)
, Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.S0 RiscV.ADDI RiscV.SP totalStackSize)
]
quadruple stackSize StopQuadruple =
let totalStackSize = stackSize + 8
in pure $ Vector.fromList
[ Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.S0 RiscV.LW RiscV.SP 0)
, Instruction (RiscV.BaseInstruction RiscV.Load $ RiscV.I RiscV.RA RiscV.LW RiscV.SP 4)
, Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP totalStackSize)
, Instruction (RiscV.BaseInstruction RiscV.Jalr $ RiscV.I RiscV.RA RiscV.JALR RiscV.Zero 0)
]
quadruple _ (ParameterQuadruple operand1) =
let (operandRegister, statements) = loadImmediateOrRegister operand1 RiscV.A0
in pure $ mappend statements $ Vector.fromList
[ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP (negate 4))
, Instruction (RiscV.BaseInstruction RiscV.Store $ RiscV.S 0 RiscV.SW RiscV.SP operandRegister)
]
quadruple _ (CallQuadruple callName numberOfArguments) =
let restoreStackSize = numberOfArguments * 4
in pure $ Vector.fromList
[ Instruction (RiscV.CallInstruction callName)
, Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I RiscV.SP RiscV.ADDI RiscV.SP restoreStackSize)
]
quadruple _ (AddQuadruple operand1 operand2 store) =
commutativeBinary (+) RiscV.ADD (RiscV.Funct7 0b0000000) (operand1, operand2) store
quadruple _ (ProductQuadruple operand1 operand2 store) =
commutativeBinary (*) RiscV.MUL (RiscV.Funct7 0b0000001) (operand1, operand2) store
quadruple _ (SubtractionQuadruple operand1 operand2 store)
| IntOperand immediateOperand1 <- operand1
, IntOperand immediateOperand2 <- operand2 =
let (storeRegister, storeStatements) = storeToStore store
in pure $ lui (immediateOperand1 - immediateOperand2) storeRegister <> storeStatements
| VariableOperand variableOperand1 <- operand1
, VariableOperand variableOperand2 <- operand2 =
let (storeRegister, storeStatements) = storeToStore store
(operandRegister1, statements1) = loadFromStore variableOperand1
(operandRegister2, statements2) = loadFromStore variableOperand2
instruction = Instruction
$ RiscV.BaseInstruction RiscV.Op
$ RiscV.R storeRegister RiscV.SUB operandRegister1 operandRegister2
$ RiscV.Funct7 0b0100000
in pure $ statements1 <> statements2 <> Vector.cons instruction storeStatements
| IntOperand immediateOperand1 <- operand1
, VariableOperand variableOperand2 <- operand2 =
let (storeRegister, storeStatements) = storeToStore store
statements1 = lui immediateOperand1 storeRegister
(operandRegister2, statements2) = loadFromStore variableOperand2
instruction = Instruction
$ RiscV.BaseInstruction RiscV.Op
$ RiscV.R storeRegister RiscV.SUB storeRegister operandRegister2
$ RiscV.Funct7 0b0100000
in pure $ statements1 <> statements2 <> Vector.cons instruction storeStatements
| VariableOperand variableOperand1 <- operand1
, IntOperand immediateOperand2 <- operand2 =
let (storeRegister, storeStatements) = storeToStore store
statements2 = lui (negate immediateOperand2) storeRegister
(operandRegister1, statements1) = loadFromStore variableOperand1
instruction = Instruction
$ RiscV.BaseInstruction RiscV.Op
$ RiscV.R storeRegister RiscV.ADD storeRegister operandRegister1
$ RiscV.Funct7 0b0000000
in pure $ statements1 <> statements2 <> Vector.cons instruction storeStatements
quadruple _ (NegationQuadruple operand1 store)
| IntOperand immediateOperand1 <- operand1 =
let (storeRegister, storeStatements) = storeToStore store
in pure $ lui (negate immediateOperand1) storeRegister <> storeStatements
| VariableOperand variableOperand1 <- operand1 =
let (storeRegister, storeStatements) = storeToStore store
(operandRegister1, statements1) = loadFromStore variableOperand1
instruction = Instruction
$ RiscV.BaseInstruction RiscV.Op
$ RiscV.R storeRegister RiscV.SUB RiscV.Zero operandRegister1
$ RiscV.Funct7 0b0100000
in pure $ statements1 <> Vector.cons instruction storeStatements
quadruple _ (DivisionQuadruple operand1 operand2 store)
| IntOperand immediateOperand1 <- operand1
, IntOperand immediateOperand2 <- operand2 =
if immediateOperand2 == 0
then pure $ Vector.singleton
$ Instruction (RiscV.CallInstruction "_divide_by_zero_error")
else
let (storeRegister, storeStatements) = storeToStore store
in pure $ lui (quot immediateOperand1 immediateOperand2) storeRegister <> storeStatements
| VariableOperand variableOperand1 <- operand1
, VariableOperand variableOperand2 <- operand2 = do
let (storeRegister, storeStatements) = storeToStore store
(operandRegister1, statements1) = loadFromStore variableOperand1
(operandRegister2, statements2) = loadFromStore variableOperand2
divisionInstruction = Instruction
$ RiscV.BaseInstruction RiscV.Op
$ RiscV.R storeRegister RiscV.DIV operandRegister1 operandRegister2 (RiscV.Funct7 0b0000001)
branchLabel <- createLabel
let branchInstruction = Instruction
$ RiscV.RelocatableInstruction RiscV.Branch
$ RiscV.RBranch branchLabel RiscV.BNE RiscV.Zero operandRegister2
pure $ statements1 <> statements2 <> Vector.fromList
[ branchInstruction
, Instruction (RiscV.CallInstruction "_divide_by_zero_error")
, JumpLabel branchLabel []
, divisionInstruction
] <> storeStatements
| VariableOperand variableOperand1 <- operand1
, IntOperand immediateOperand2 <- operand2 =
let (storeRegister, storeStatements) = storeToStore store
statements2 = lui immediateOperand2 storeRegister
(operandRegister1, statements1) = loadFromStore variableOperand1
operationInstruction
| immediateOperand2 == 0 =
RiscV.CallInstruction "_divide_by_zero_error"
| otherwise = RiscV.BaseInstruction RiscV.Op
$ RiscV.R storeRegister RiscV.DIV operandRegister1 storeRegister
$ RiscV.Funct7 0b0000001
in pure $ statements1 <> statements2
<> Vector.cons (Instruction operationInstruction) storeStatements
| IntOperand immediateOperand1 <- operand1
, VariableOperand variableOperand2 <- operand2 = do
let (storeRegister, storeStatements) = storeToStore store
statements1 = lui immediateOperand1 storeRegister
(operandRegister2, statements2) = loadFromStore variableOperand2
divisionInstruction = Instruction
$ RiscV.BaseInstruction RiscV.Op
$ RiscV.R storeRegister RiscV.DIV storeRegister operandRegister2 (RiscV.Funct7 0b0000001)
branchLabel <- createLabel
let branchInstruction = Instruction
$ RiscV.RelocatableInstruction RiscV.Branch
$ RiscV.RBranch branchLabel RiscV.BNE RiscV.Zero operandRegister2
pure $ statements1 <> statements2 <> Vector.fromList
[ branchInstruction
, Instruction (RiscV.CallInstruction "_divide_by_zero_error")
, JumpLabel branchLabel []
, divisionInstruction
] <> storeStatements
quadruple _ (LabelQuadruple (Label label)) = pure $ Vector.singleton $ JumpLabel label mempty
quadruple _ (GoToQuadruple label) = pure $ Vector.singleton $ unconditionalJal label
quadruple _ (EqualQuadruple operand1 operand2 goToLabel) =
commutativeComparison (==) RiscV.BEQ (operand1, operand2) goToLabel
quadruple _ (NonEqualQuadruple operand1 operand2 goToLabel) =
commutativeComparison (/=) RiscV.BNE (operand1, operand2) goToLabel
quadruple _ (LessQuadruple operand1 operand2 goToLabel) =
lessThan (operand1, operand2) goToLabel
quadruple _ (GreaterQuadruple operand1 operand2 goToLabel) =
lessThan (operand2, operand1) goToLabel
quadruple _ (LessOrEqualQuadruple operand1 operand2 goToLabel) =
lessOrEqualThan (operand1, operand2) goToLabel
quadruple _ (GreaterOrEqualQuadruple operand1 operand2 goToLabel) =
lessOrEqualThan (operand2, operand1) goToLabel
quadruple _ (AssignQuadruple operand1 store)
| IntOperand immediateOperand1 <- operand1 =
let (storeRegister, storeStatements) = storeToStore store
in pure $ lui immediateOperand1 storeRegister <> storeStatements
| VariableOperand variableOperand1 <- operand1 =
let (operandRegister1, statements1) = loadFromStore variableOperand1
(storeRegister, storeStatements) = storeToStore store
instruction = Instruction
$ RiscV.BaseInstruction RiscV.OpImm
$ RiscV.I storeRegister RiscV.ADDI operandRegister1 0
in pure $ statements1 <> Vector.cons instruction storeStatements
quadruple _ (ArrayAssignQuadruple assigneeOperand indexOperand store)
| IntOperand immediateAssigneeOperand <- assigneeOperand =
let (storeRegister, storeStatements) = storeWithOffset store indexOperand
in pure $ lui immediateAssigneeOperand storeRegister <> storeStatements
| VariableOperand variableAssigneeOperand <- assigneeOperand =
let (assigneeOperandRegister, assigneeStatements) = loadFromStore variableAssigneeOperand
(storeRegister, storeStatements) = storeWithOffset store indexOperand
instruction = Instruction
$ RiscV.BaseInstruction RiscV.OpImm
$ RiscV.I storeRegister RiscV.ADDI assigneeOperandRegister 0
in pure $ assigneeStatements <> Vector.cons instruction storeStatements
where
storeWithOffset :: RiscVStore -> Operand RiscVStore -> (RiscV.XRegister, Vector Statement)
storeWithOffset (RegisterStore register) _ = (register, mempty)
storeWithOffset (StackStore offset register) (IntOperand indexOffset) =
let storeInstruction = Instruction
$ RiscV.BaseInstruction RiscV.Store
$ RiscV.S (fromIntegral $ offset + indexOffset * 4) RiscV.SW RiscV.S0 register
in (register, Vector.singleton storeInstruction)
storeWithOffset (StackStore offset register) (VariableOperand indexOffset) =
let storeInstruction = Instruction
$ RiscV.BaseInstruction RiscV.Store
$ RiscV.S (fromIntegral offset) RiscV.SW immediateRegister register
statements = calculateIndexOffset indexOffset
in (register, Vector.snoc statements storeInstruction)
quadruple _ (ArrayQuadruple assigneeVariable indexOperand store) =
let (operandRegister1, statements1) = loadWithOffset assigneeVariable indexOperand
(storeRegister, storeStatements) = storeToStore store
instruction = Instruction
$ RiscV.BaseInstruction RiscV.OpImm
$ RiscV.I storeRegister RiscV.ADDI operandRegister1 0
in pure $ statements1 <> Vector.cons instruction storeStatements
where
loadWithOffset :: RiscVStore -> Operand RiscVStore -> (RiscV.XRegister, Vector Statement)
loadWithOffset (RegisterStore register) _ = (register, mempty)
loadWithOffset (StackStore offset register) (IntOperand indexOffset) =
let loadInstruction = Instruction
$ RiscV.BaseInstruction RiscV.Load
$ RiscV.I register RiscV.LW RiscV.S0 (fromIntegral $ offset + indexOffset * 4)
in (register, Vector.singleton loadInstruction)
loadWithOffset (StackStore offset register) (VariableOperand indexOffset) =
let loadInstruction = Instruction
$ RiscV.BaseInstruction RiscV.Load
$ RiscV.I register RiscV.SW immediateRegister (fromIntegral offset)
statements = calculateIndexOffset indexOffset
in (register, Vector.snoc statements loadInstruction)
calculateIndexOffset :: RiscVStore -> Vector Statement
calculateIndexOffset indexOffset =
let (indexRegister, indexStatements) = loadFromStore indexOffset
baseRegisterInstruction = Instruction
$ RiscV.BaseInstruction RiscV.OpImm
$ RiscV.I immediateRegister RiscV.ADDI RiscV.Zero 4
indexRelativeOffset = Instruction
$ RiscV.BaseInstruction RiscV.Op
$ RiscV.R immediateRegister RiscV.MUL immediateRegister indexRegister (RiscV.Funct7 0b0000001)
registerWithOffset = Instruction
$ RiscV.BaseInstruction RiscV.Op
$ RiscV.R immediateRegister RiscV.ADD immediateRegister RiscV.S0 (RiscV.Funct7 0b0000000)
statements = Vector.fromList
[ baseRegisterInstruction
, indexRelativeOffset
, registerWithOffset
]
in indexStatements <> statements
unconditionalJal :: Label -> Statement
unconditionalJal (Label goToLabel) = Instruction
$ RiscV.RelocatableInstruction RiscV.Jal
$ RiscV.RJal RiscV.Zero goToLabel
loadImmediateOrRegister :: RiscVOperand -> RiscV.XRegister -> (RiscV.XRegister, Vector Statement)
loadImmediateOrRegister (IntOperand intValue) targetRegister =
(targetRegister, lui intValue targetRegister)
loadImmediateOrRegister (VariableOperand store) _ = loadFromStore store
lui :: Int32 -> RiscV.XRegister -> Vector Statement
lui intValue targetRegister
| intValue >= -2048
, intValue <= 2047 = Vector.singleton
$ Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI RiscV.Zero lo)
| intValue .&. 0x800 /= 0 = Vector.fromList
[ Instruction (RiscV.BaseInstruction RiscV.Lui $ RiscV.U targetRegister $ fromIntegral $ succ hi)
, Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI targetRegister lo)
]
| otherwise = Vector.fromList
[ Instruction (RiscV.BaseInstruction RiscV.Lui $ RiscV.U targetRegister $ fromIntegral hi)
, Instruction (RiscV.BaseInstruction RiscV.OpImm $ RiscV.I targetRegister RiscV.ADDI targetRegister lo)
]
where
hi = intValue `shiftR` 12
lo = fromIntegral intValue
commutativeBinary
:: (Int32 -> Int32 -> Int32)
-> RiscV.Funct3
-> RiscV.Funct7
-> (Operand RiscVStore, Operand RiscVStore)
-> Store RiscV.XRegister
-> RiscVGenerator (Vector Statement)
commutativeBinary immediateOperation funct3 funct7 (operand1, operand2) store
| IntOperand immediateOperand1 <- operand1
, IntOperand immediateOperand2 <- operand2 =
let (storeRegister, storeStatements) = storeToStore store
immediateOperation' = immediateOperation immediateOperand1 immediateOperand2
in pure $ lui immediateOperation' storeRegister <> storeStatements
| VariableOperand variableOperand1 <- operand1
, VariableOperand variableOperand2 <- operand2 =
let (operandRegister1, statements1) = loadFromStore variableOperand1
(operandRegister2, statements2) = loadFromStore variableOperand2
(storeRegister, storeStatements) = storeToStore store
instruction = Instruction $ RiscV.BaseInstruction RiscV.Op
$ RiscV.R storeRegister funct3 operandRegister1 operandRegister2 funct7
in pure $ statements1 <> statements2
<> Vector.cons instruction storeStatements
| VariableOperand variableOperand1 <- operand1
, IntOperand immediateOperand2 <- operand2 =
commutativeImmediateRegister variableOperand1 immediateOperand2
| IntOperand immediateOperand1 <- operand1
, VariableOperand variableOperand2 <- operand2 =
commutativeImmediateRegister variableOperand2 immediateOperand1
where
commutativeImmediateRegister variableOperand immediateOperand =
let (storeRegister, storeStatements) = storeToStore store
immediateStatements = lui immediateOperand storeRegister
(operandRegister, registerStatements) = loadFromStore variableOperand
instruction = Instruction
$ RiscV.BaseInstruction RiscV.Op
$ RiscV.R storeRegister funct3 storeRegister operandRegister funct7
in pure $ immediateStatements <> registerStatements
<> Vector.cons instruction storeStatements
commutativeComparison
:: (Int32 -> Int32 -> Bool)
-> RiscV.Funct3
-> (Operand RiscVStore, Operand RiscVStore)
-> Label
-> RiscVGenerator (Vector Statement)
commutativeComparison immediateOperation funct3 (operand1, operand2) goToLabel
| IntOperand immediateOperand1 <- operand1
, IntOperand immediateOperand2 <- operand2 =
if immediateOperation immediateOperand1 immediateOperand2
then pure $ Vector.singleton $ unconditionalJal goToLabel
else pure Vector.empty
| VariableOperand variableOperand1 <- operand1
, VariableOperand variableOperand2 <- operand2 = do
let (operandRegister1, statements1) = loadFromStore variableOperand1
(operandRegister2, statements2) = loadFromStore variableOperand2
Label goToLabel' = goToLabel
pure $ Vector.snoc (statements1 <> statements2)
$ Instruction
$ RiscV.RelocatableInstruction RiscV.Branch
$ RiscV.RBranch goToLabel' funct3 operandRegister1 operandRegister2
| VariableOperand variableOperand1 <- operand1
, IntOperand immediateOperand2 <- operand2 =
compareImmediateRegister variableOperand1 immediateOperand2
| IntOperand immediateOperand1 <- operand1
, VariableOperand variableOperand2 <- operand2 =
compareImmediateRegister variableOperand2 immediateOperand1
where
compareImmediateRegister variableOperand immediateOperand =
let immediateStatements = lui immediateOperand immediateRegister
(operandRegister, registerStatements) = loadFromStore variableOperand
Label goToLabel' = goToLabel
in pure $ Vector.snoc (immediateStatements <> registerStatements)
$ Instruction
$ RiscV.RelocatableInstruction RiscV.Branch
$ RiscV.RBranch goToLabel' funct3 operandRegister immediateRegister
lessThan :: (Operand RiscVStore, Operand RiscVStore) -> Label -> RiscVGenerator (Vector Statement)
lessThan (operand1, operand2) goToLabel
| IntOperand immediateOperand1 <- operand1
, IntOperand immediateOperand2 <- operand2 =
if immediateOperand1 < immediateOperand2
then pure $ Vector.singleton $ unconditionalJal goToLabel
else pure Vector.empty
| VariableOperand variableOperand1 <- operand1
, VariableOperand variableOperand2 <- operand2 = do
let (operandRegister1, statements1) = loadFromStore variableOperand1
(operandRegister2, statements2) = loadFromStore variableOperand2
Label goToLabel' = goToLabel
pure $ Vector.snoc (statements1 <> statements2)
$ Instruction
$ RiscV.RelocatableInstruction RiscV.Branch
$ RiscV.RBranch goToLabel' RiscV.BLT operandRegister1 operandRegister2
| VariableOperand variableOperand1 <- operand1
, IntOperand immediateOperand2 <- operand2 =
let statements2 = lui immediateOperand2 immediateRegister
(operandRegister1, statements1) = loadFromStore variableOperand1
Label goToLabel' = goToLabel
in pure $ Vector.snoc (statements1 <> statements2)
$ Instruction
$ RiscV.RelocatableInstruction RiscV.Branch
$ RiscV.RBranch goToLabel' RiscV.BLT operandRegister1 immediateRegister
| IntOperand immediateOperand1 <- operand1
, VariableOperand variableOperand2 <- operand2 =
let statements1 = lui immediateOperand1 immediateRegister
(operandRegister2, statements2) = loadFromStore variableOperand2
Label goToLabel' = goToLabel
in pure $ Vector.snoc (statements1 <> statements2)
$ Instruction
$ RiscV.RelocatableInstruction RiscV.Branch
$ RiscV.RBranch goToLabel' RiscV.BLT immediateRegister operandRegister2
lessOrEqualThan :: (Operand RiscVStore, Operand RiscVStore) -> Label -> RiscVGenerator (Vector Statement)
lessOrEqualThan (operand1, operand2) goToLabel
| IntOperand immediateOperand1 <- operand1
, IntOperand immediateOperand2 <- operand2 =
if immediateOperand1 <= immediateOperand2
then pure $ Vector.singleton $ unconditionalJal goToLabel
else pure Vector.empty
| VariableOperand variableOperand1 <- operand1
, VariableOperand variableOperand2 <- operand2 = do
let (operandRegister1, statements1) = loadFromStore variableOperand1
(operandRegister2, statements2) = loadFromStore variableOperand2
Label goToLabel' = goToLabel
pure $ Vector.snoc (statements1 <> statements2)
$ Instruction
$ RiscV.RelocatableInstruction RiscV.Branch
$ RiscV.RBranch goToLabel' RiscV.BGE operandRegister2 operandRegister1
| VariableOperand variableOperand1 <- operand1
, IntOperand immediateOperand2 <- operand2 =
let statements2 = lui immediateOperand2 immediateRegister
(operandRegister1, statements1) = loadFromStore variableOperand1
Label goToLabel' = goToLabel
in pure $ Vector.snoc (statements1 <> statements2)
$ Instruction
$ RiscV.RelocatableInstruction RiscV.Branch
$ RiscV.RBranch goToLabel' RiscV.BGE immediateRegister operandRegister1
| IntOperand immediateOperand1 <- operand1
, VariableOperand variableOperand2 <- operand2 =
let statements1 = lui immediateOperand1 immediateRegister
(operandRegister2, statements2) = loadFromStore variableOperand2
Label goToLabel' = goToLabel
in pure $ Vector.snoc (statements1 <> statements2)
$ Instruction
$ RiscV.RelocatableInstruction RiscV.Branch
$ RiscV.RBranch goToLabel' RiscV.BGE operandRegister2 immediateRegister
loadFromStore :: RiscVStore -> (RiscV.XRegister, Vector Statement)
loadFromStore (RegisterStore register) = (register, mempty)
loadFromStore (StackStore offset register) =
let loadInstruction = Instruction
$ RiscV.BaseInstruction RiscV.Load
$ RiscV.I register RiscV.LW RiscV.S0 (fromIntegral offset)
in (register, Vector.singleton loadInstruction)
storeToStore :: RiscVStore -> (RiscV.XRegister, Vector Statement)
storeToStore (RegisterStore register) = (register, mempty)
storeToStore (StackStore offset register) =
let storeInstruction = Instruction
$ RiscV.BaseInstruction RiscV.Store
$ RiscV.S (fromIntegral offset) RiscV.SW RiscV.S0 register
in (register, Vector.singleton storeInstruction)

338
lib/Language/Elna/RiscV/ElfWriter.hs Normal file
View File

@ -0,0 +1,338 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
-- | Writer assembler to an object file.
module Language.Elna.RiscV.ElfWriter
( riscv32Elf
) where
import Data.ByteString (StrictByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Builder as ByteString.Builder
import Data.ByteString.Lazy (LazyByteString)
import qualified Data.ByteString.Lazy as LazyByteString
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Language.Elna.Object.ElfCoder
( ByteOrder(..)
, Elf32_Ehdr(..)
, Elf32_Half
, Elf32_Word
, Elf32_Sym(..)
, ElfMachine(..)
, ElfType(..)
, ElfVersion(..)
, ElfIdentification(..)
, ElfClass(..)
, ElfData(..)
, Elf32_Shdr(..)
, ElfSectionType(..)
, ElfSymbolBinding(..)
, ElfSymbolType(..)
, Elf32_Rel(..)
, ElfWriter(..)
, ElfHeaderResult(..)
, ElfEnvironment(..)
, UnresolvedRelocation(..)
, UnresolvedRelocations(..)
, addHeaderToResult
, addSectionHeader
, elf32Sym
, elfHeaderSize
, elfSectionsSize
, stInfo
, rInfo
, elf32Rel
, shfInfoLink
, partitionSymbols
, putSectionHeader
)
import qualified Language.Elna.Architecture.RiscV as RiscV
import qualified Data.Text.Encoding as Text
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.State (get, gets)
import Language.Elna.RiscV.CodeGenerator (Directive(..), Statement(..))
import Language.Elna.Object.StringTable (StringTable)
import qualified Language.Elna.Object.StringTable as StringTable
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import GHC.Records (HasField(..))
data TextAccumulator = TextAccumulator
{ encodedAccumulator :: LazyByteString
, relocationAccumulator :: Vector UnresolvedRelocation
, symbolAccumulator :: ElfHeaderResult Elf32_Sym
, definitionAccumulator :: HashSet StrictByteString
}
riscv32Elf :: Vector Statement -> ElfWriter Elf32_Ehdr
riscv32Elf code = text code
>>= symtab
>>= uncurry symrel
>>= strtab
>> shstrtab
>>= riscv32Header
where
riscv32Header :: Elf32_Half -> ElfWriter Elf32_Ehdr
riscv32Header shstrndx = do
ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
pure $ Elf32_Ehdr
{ e_version = EV_CURRENT
, e_type = ET_REL
, e_shstrndx = shstrndx
, e_shoff = elfSectionsSize sectionHeaders
, e_shnum = fromIntegral (Vector.length sectionHeaders)
, e_shentsize = 40
, e_phoff = 0
, e_phnum = 0
, e_phentsize = 32
, e_machine = EM_RISCV
, e_ident = ElfIdentification ELFCLASS32 ELFDATA2LSB
, e_flags = 0x4 -- EF_RISCV_FLOAT_ABI_DOUBLE
, e_entry = 0
, e_ehsize = fromIntegral elfHeaderSize
}
text :: Vector Statement -> ElfWriter UnresolvedRelocations
text code = do
ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
let textTabIndex = fromIntegral $ Vector.length sectionHeaders
initialHeaders = ElfHeaderResult mempty
$ Vector.singleton
$ Elf32_Sym
{ st_value = 0
, st_size = 0
, st_shndx = 0
, st_other = 0
, st_name = 0
, st_info = 0
}
TextAccumulator{..} = encodeFunctions textTabIndex code
$ TextAccumulator
{ encodedAccumulator = mempty
, relocationAccumulator = Vector.empty
, symbolAccumulator = initialHeaders
, definitionAccumulator = HashSet.empty
}
size = fromIntegral $ LazyByteString.length encodedAccumulator
newHeader = Elf32_Shdr
{ sh_type = SHT_PROGBITS
, sh_size = size
, sh_offset = elfSectionsSize sectionHeaders
, sh_name = StringTable.size sectionNames
, sh_link = 0
, sh_info = 0
, sh_flags = 0b110
, sh_entsize = 0
, sh_addralign = 4
, sh_addr = 0
}
putSectionHeader ".text" newHeader $ LazyByteString.toStrict encodedAccumulator
let filterPredicate :: StrictByteString -> Bool
filterPredicate = not
. (`StringTable.elem` getField @"sectionNames" symbolAccumulator)
symbolResult = HashSet.foldl' encodeEmptyDefinitions symbolAccumulator
$ HashSet.filter filterPredicate definitionAccumulator
pure $ UnresolvedRelocations relocationAccumulator symbolResult
$ fromIntegral $ Vector.length sectionHeaders
where
encodeEmptyDefinitions (ElfHeaderResult names entries) definition =
let nextEntry = Elf32_Sym
{ st_value = 0
, st_size = 0
, st_shndx = 0
, st_other = 0
, st_name = StringTable.size names
, st_info = stInfo STB_GLOBAL STT_FUNC
}
in ElfHeaderResult (StringTable.append definition names)
$ Vector.snoc entries nextEntry
encodeFunctions shndx instructions textAccumulator
| Just (instruction, rest) <- Vector.uncons instructions =
case instruction of
Instruction _ ->
let (textAccumulator', rest') = encodeInstructions shndx (textAccumulator, instructions)
in encodeFunctions shndx rest' textAccumulator'
JumpLabel labelName directives ->
let (TextAccumulator{..}, rest') =
encodeInstructions shndx (textAccumulator, rest)
newEntry = Elf32_Sym
{ st_value = fromIntegral
$ LazyByteString.length
$ getField @"encodedAccumulator" textAccumulator
, st_size = fromIntegral $ LazyByteString.length encodedAccumulator
, st_shndx = shndx
, st_other = 0
, st_name = StringTable.size $ getField @"sectionNames" symbolAccumulator
, st_info = stInfo (directivesBinding directives) STT_FUNC
}
in encodeFunctions shndx rest'
$ TextAccumulator
{ encodedAccumulator = encodedAccumulator
, relocationAccumulator = relocationAccumulator
, symbolAccumulator =
addHeaderToResult (Text.encodeUtf8 labelName) newEntry symbolAccumulator
, definitionAccumulator = definitionAccumulator
}
| otherwise = textAccumulator
directivesBinding directives
| GlobalDirective `elem` directives = STB_GLOBAL
| otherwise = STB_LOCAL
encodeInstructions shndx (TextAccumulator encoded relocations symbolResult definitions, instructions)
| Just (Instruction instruction, rest) <- Vector.uncons instructions =
let offset = fromIntegral $ LazyByteString.length encoded
unresolvedRelocation = case instruction of
RiscV.RelocatableInstruction _ instructionType
| RiscV.RHigher20 _ symbolName <- instructionType
-> Just -- R_RISCV_HI20
$ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 26
| RiscV.RLower12I _ _ _ symbolName <- instructionType
-> Just -- R_RISCV_LO12_I
$ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 27
| RiscV.RLower12S symbolName _ _ _ <- instructionType
-> Just -- R_RISCV_LO12_S
$ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 28
| RiscV.RBranch symbolName _ _ _ <- instructionType
-> Just -- R_RISCV_BRANCH
$ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 16
| RiscV.RJal _ symbolName <- instructionType
-> Just -- R_RISCV_JAL
$ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 17
RiscV.CallInstruction symbolName
-> Just -- R_RISCV_CALL_PLT
$ UnresolvedRelocation (Text.encodeUtf8 symbolName) offset 19
RiscV.BaseInstruction _ _ -> Nothing
chunk = ByteString.Builder.toLazyByteString
$ RiscV.instruction instruction
result = TextAccumulator
(encoded <> chunk)
(maybe relocations (Vector.snoc relocations) unresolvedRelocation)
symbolResult
(addDefinition unresolvedRelocation definitions)
in encodeInstructions shndx (result, rest)
| Just (JumpLabel labelName directives , rest) <- Vector.uncons instructions
, FunctionDirective `notElem` directives =
let newEntry = Elf32_Sym
{ st_value = fromIntegral $ LazyByteString.length encoded
, st_size = 0
, st_shndx = shndx
, st_other = 0
, st_name = StringTable.size $ getField @"sectionNames" symbolResult
, st_info = stInfo (directivesBinding directives) STT_NOTYPE
}
result = TextAccumulator
encoded
relocations
(addHeaderToResult (Text.encodeUtf8 labelName) newEntry symbolResult)
definitions
in encodeInstructions shndx (result, rest)
| otherwise = (TextAccumulator encoded relocations symbolResult definitions, instructions)
addDefinition (Just (UnresolvedRelocation symbolName _ _)) =
HashSet.insert symbolName
addDefinition Nothing = id
shstrtab :: ElfWriter Elf32_Half
shstrtab = do
ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
let stringTable = ".shstrtab"
currentNamesSize = StringTable.size sectionNames
nextHeader = Elf32_Shdr
{ sh_type = SHT_STRTAB
, sh_size = currentNamesSize -- Adding trailing null character.
+ fromIntegral (succ $ ByteString.length stringTable)
, sh_offset = elfSectionsSize sectionHeaders
, sh_name = currentNamesSize
, sh_link = 0
, sh_info = 0
, sh_flags = 0
, sh_entsize = 0
, sh_addralign = 1
, sh_addr = 0
}
addSectionHeader stringTable nextHeader
ElfEnvironment{..} <- ElfWriter get
liftIO $ ByteString.hPut objectHandle
$ StringTable.encode
$ getField @"sectionNames" objectHeaders
pure $ fromIntegral $ Vector.length sectionHeaders
symtab :: UnresolvedRelocations -> ElfWriter (Elf32_Word, UnresolvedRelocations)
symtab (UnresolvedRelocations relocationList symbolResult index) = do
ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
let (localSymbols, globalSymbols) = partitionSymbols symbolResult
sortedSymbols = localSymbols <> globalSymbols
sortedResult = symbolResult{ sectionHeaders = sortedSymbols }
encodedSymbols = LazyByteString.toStrict
$ ByteString.Builder.toLazyByteString
$ foldMap (elf32Sym LSB) sortedSymbols
symHeader = Elf32_Shdr
{ sh_type = SHT_SYMTAB
, sh_size = fromIntegral $ ByteString.length encodedSymbols
, sh_offset = elfSectionsSize sectionHeaders
, sh_name = StringTable.size sectionNames
, sh_link = fromIntegral $ Vector.length sectionHeaders + 2
, sh_info = fromIntegral $ Vector.length localSymbols
, sh_flags = 0
, sh_entsize = 16
, sh_addralign = 4
, sh_addr = 0
}
putSectionHeader ".symtab" symHeader encodedSymbols
pure
( fromIntegral $ Vector.length sectionHeaders
, UnresolvedRelocations relocationList sortedResult index
)
symrel :: Elf32_Word -> UnresolvedRelocations -> ElfWriter StringTable
symrel sectionHeadersLength relocations = do
ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
let UnresolvedRelocations relocationList symbols index = relocations
encodedRelocations = LazyByteString.toStrict
$ ByteString.Builder.toLazyByteString
$ Vector.foldMap (either (const mempty) (elf32Rel LSB))
$ resolveRelocation symbols <$> relocationList
relHeader = Elf32_Shdr
{ sh_type = SHT_REL
, sh_size = fromIntegral $ ByteString.length encodedRelocations
, sh_offset = elfSectionsSize sectionHeaders
, sh_name = StringTable.size sectionNames
, sh_link = sectionHeadersLength
, sh_info = index
, sh_flags = shfInfoLink
, sh_entsize = 8
, sh_addralign = 4
, sh_addr = 0
}
putSectionHeader ".rel.text" relHeader encodedRelocations
pure $ getField @"sectionNames" symbols
where
takeStringZ stringTable Elf32_Sym{ st_name }
= StringTable.index st_name stringTable
resolveRelocation (ElfHeaderResult stringTable entries) unresolvedRelocation
| UnresolvedRelocation symbolName offset type' <- unresolvedRelocation
, Just entry <- Vector.findIndex ((== symbolName) . takeStringZ stringTable) entries =
Right $ Elf32_Rel
{ r_offset = offset
, r_info = rInfo (fromIntegral entry) type'
}
| otherwise = Left unresolvedRelocation
strtab :: StringTable -> ElfWriter ()
strtab stringTable = do
ElfHeaderResult{..} <- ElfWriter $ gets $ getField @"objectHeaders"
let strHeader = Elf32_Shdr
{ sh_type = SHT_STRTAB
, sh_size = StringTable.size stringTable
, sh_offset = elfSectionsSize sectionHeaders
, sh_name = StringTable.size sectionNames
, sh_link = 0
, sh_info = 0
, sh_flags = 0
, sh_entsize = 0
, sh_addralign = 1
, sh_addr = 0
}
putSectionHeader ".strtab" strHeader $ StringTable.encode stringTable

341
rakelib/cross.rake Normal file
View File

@ -0,0 +1,341 @@
# This Source Code Form is subject to the terms of the Mozilla Public License,
# v. 2.0. If a copy of the MPL was not distributed with this file, You can
# obtain one at https://mozilla.org/MPL/2.0/. -}
require 'pathname'
require 'uri'
require 'net/http'
require 'rake/clean'
require 'open3'
require 'etc'
require_relative 'shared'
GCC_VERSION = "14.2.0"
BINUTILS_VERSION = '2.43.1'
GLIBC_VERSION = '2.40'
KERNEL_VERSION = '5.15.166'
CLOBBER.include TMP
class BuildTarget
attr_accessor(:build, :gcc, :target, :tmp)
def gxx
@gcc.gsub 'c', '+'
end
def sysroot
tmp + 'sysroot'
end
def rootfs
tmp + 'rootfs'
end
def tools
tmp + 'tools'
end
def configuration
case target
when /^riscv[[:digit:]]+-/
[
'--with-arch=rv32imafdc',
'--with-abi=ilp32d',
'--with-tune=rocket',
'--with-isa-spec=20191213'
]
else
[]
end
end
end
def gcc_verbose(gcc_binary)
read, write = IO.pipe
sh({'LANG' => 'C'}, gcc_binary, '--verbose', err: write)
write.close
output = read.read
read.close
output
end
def find_build_target(gcc_version, task)
gcc_binary = 'gcc'
output = gcc_verbose gcc_binary
if output.start_with? 'Apple clang'
gcc_binary = "gcc-#{gcc_version.split('.').first}"
output = gcc_verbose gcc_binary
end
result = output
.lines
.each_with_object(BuildTarget.new) do |line, accumulator|
if line.start_with? 'Target: '
accumulator.build = line.split(' ').last.strip
elsif line.start_with? 'COLLECT_GCC'
accumulator.gcc = line.split('=').last.strip
end
end
result.tmp = TMP
task.with_defaults target: 'riscv32-unknown-linux-gnu'
result.target = task[:target]
result
end
def download_and_unarchive(url, target)
case File.extname url.path
when '.bz2'
archive_type = '-j'
root_directory = File.basename url.path, '.tar.bz2'
when '.xz'
archive_type = '-J'
root_directory = File.basename url.path, '.tar.xz'
else
raise "Unsupported archive type #{url.path}."
end
Net::HTTP.start(url.host, url.port, use_ssl: url.scheme == 'https') do |http|
request = Net::HTTP::Get.new url.request_uri
http.request request do |response|
case response
when Net::HTTPRedirection
download_and_unarchive URI.parse(response['location'])
when Net::HTTPSuccess
Open3.popen2 'tar', '-C', target.to_path, archive_type, '-xv' do |stdin, stdout, wait_thread|
Thread.new do
stdout.each { |line| puts line }
end
response.read_body do |chunk|
stdin.write chunk
end
stdin.close
wait_thread.value
end
else
response.error!
end
end
end
target + root_directory
end
namespace :cross do
desc 'Build cross binutils'
task :binutils, [:target] do |_, args|
options = find_build_target GCC_VERSION, args
options.tools.mkpath
source_directory = download_and_unarchive(
URI.parse("https://ftp.gnu.org/gnu/binutils/binutils-#{BINUTILS_VERSION}.tar.xz"),
options.tools)
cwd = source_directory.dirname + 'build-binutils'
cwd.mkpath
options.rootfs.mkpath
env = {
'CC' => options.gcc,
'CXX' => options.gxx
}
configure_options = [
"--prefix=#{options.rootfs.realpath}",
"--target=#{options.target}",
'--disable-nls',
'--enable-gprofng=no',
'--disable-werror',
'--enable-default-hash-style=gnu',
'--disable-libquadmath'
]
configure = source_directory.relative_path_from(cwd) + 'configure'
sh env, configure.to_path, *configure_options, chdir: cwd.to_path
sh env, 'make', '-j', Etc.nprocessors.to_s, chdir: cwd.to_path
sh env, 'make', 'install', chdir: cwd.to_path
end
desc 'Build stage 1 GCC'
task :gcc1, [:target] do |_, args|
options = find_build_target GCC_VERSION, args
options.tools.mkpath
source_directory = download_and_unarchive(
URI.parse("https://gcc.gnu.org/pub/gcc/releases/gcc-#{GCC_VERSION}/gcc-#{GCC_VERSION}.tar.xz"),
options.tools)
cwd = source_directory.dirname + 'build-gcc'
cwd.mkpath
options.rootfs.mkpath
options.sysroot.mkpath
sh 'contrib/download_prerequisites', chdir: source_directory.to_path
configure_options = options.configuration + [
"--prefix=#{options.rootfs.realpath}",
"--with-sysroot=#{options.sysroot.realpath}",
'--enable-languages=c,c++',
'--disable-shared',
'--disable-bootstrap',
'--disable-multilib',
'--disable-libmudflap',
'--disable-libssp',
'--disable-libquadmath',
'--disable-libsanitizer',
'--disable-threads',
'--disable-libatomic',
'--disable-libgomp',
'--disable-libvtv',
'--disable-libstdcxx',
'--disable-nls',
'--with-newlib',
'--without-headers',
"--target=#{options.target}",
"--build=#{options.build}",
"--host=#{options.build}"
]
flags = '-O2 -fPIC'
env = {
'CC' => options.gcc,
'CXX' => options.gxx,
'CFLAGS' => flags,
'CXXFLAGS' => flags,
'PATH' => "#{options.rootfs.realpath + 'bin'}:#{ENV['PATH']}"
}
configure = source_directory.relative_path_from(cwd) + 'configure'
sh env, configure.to_path, *configure_options, chdir: cwd.to_path
sh env, 'make', '-j', Etc.nprocessors.to_s, chdir: cwd.to_path
sh env, 'make', 'install', chdir: cwd.to_path
end
desc 'Copy glibc headers'
task :headers, [:target] do |_, args|
options = find_build_target GCC_VERSION, args
options.tools.mkpath
source_directory = download_and_unarchive(
URI.parse("https://ftp.gnu.org/gnu/glibc/glibc-#{GLIBC_VERSION}.tar.xz"),
options.tools)
include_directory = options.tools + 'include'
include_directory.mkpath
cp (source_directory + 'elf/elf.h'), (include_directory + 'elf.h')
end
desc 'Build linux kernel'
task :kernel, [:target] do |_, args|
options = find_build_target GCC_VERSION, args
options.tools.mkpath
cwd = download_and_unarchive(
URI.parse("https://cdn.kernel.org/pub/linux/kernel/v5.x/linux-#{KERNEL_VERSION}.tar.xz"),
options.tools)
env = {
'CROSS_COMPILE' => "#{options.target}-",
'ARCH' => 'riscv',
'PATH' => "#{options.rootfs.realpath + 'bin'}:#{ENV['PATH']}",
'HOSTCFLAGS' => "-D_UUID_T -D__GETHOSTUUID_H -I#{options.tools.realpath + 'include'}"
}
sh env, 'make', 'rv32_defconfig', chdir: cwd.to_path
sh env, 'make', '-j', Etc.nprocessors.to_s, chdir: cwd.to_path
sh env, 'make', 'headers', chdir: cwd.to_path
user_directory = options.sysroot + 'usr'
user_directory.mkpath
cp_r (cwd + 'usr/include'), (user_directory + 'include')
end
desc 'Build glibc'
task :glibc, [:target] do |_, args|
options = find_build_target GCC_VERSION, args
source_directory = options.tools + "glibc-#{GLIBC_VERSION}"
configure_options = [
'--prefix=/usr',
"--host=#{options.target}",
"--target=#{options.target}",
"--build=#{options.build}",
"--enable-kernel=#{KERNEL_VERSION}",
"--with-headers=#{options.sysroot.realpath + 'usr/include'}",
'--disable-nscd',
'--disable-libquadmath',
'--disable-libitm',
'--disable-werror',
'libc_cv_forced_unwind=yes'
]
bin = options.rootfs.realpath + 'bin'
env = {
'PATH' => "#{bin}:#{ENV['PATH']}",
'MAKE' => 'make' # Otherwise it uses gnumake which can be different and too old.
}
cwd = source_directory.dirname + 'build-glibc'
cwd.mkpath
configure = source_directory.relative_path_from(cwd) +'./configure'
sh env, configure.to_path, *configure_options, chdir: cwd.to_path
sh env, 'make', '-j', Etc.nprocessors.to_s, chdir: cwd.to_path
sh env, 'make', "install_root=#{options.sysroot.realpath}", 'install', chdir: cwd.to_path
end
desc 'Build stage 2 GCC'
task :gcc2, [:target] do |_, args|
options = find_build_target GCC_VERSION, args
source_directory = options.tools + "gcc-#{GCC_VERSION}"
cwd = options.tools + 'build-gcc'
rm_rf cwd
cwd.mkpath
configure_options = options.configuration + [
"--prefix=#{options.rootfs.realpath}",
"--with-sysroot=#{options.sysroot.realpath}",
'--enable-languages=c,c++,lto',
'--enable-lto',
'--enable-shared',
'--disable-bootstrap',
'--disable-multilib',
'--enable-checking=release',
'--disable-libssp',
'--disable-libquadmath',
'--enable-threads=posix',
'--with-default-libstdcxx-abi=new',
'--disable-nls',
"--target=#{options.target}",
"--build=#{options.build}",
"--host=#{options.build}"
]
flags = '-O2 -fPIC'
env = {
'CFLAGS' => flags,
'CXXFLAGS' => flags,
'PATH' => "#{options.rootfs.realpath + 'bin'}:#{ENV['PATH']}"
}
configure = source_directory.relative_path_from(cwd) + 'configure'
sh env, configure.to_path, *configure_options, chdir: cwd.to_path
sh env, 'make', '-j', Etc.nprocessors.to_s, chdir: cwd.to_path
sh env, 'make', 'install', chdir: cwd.to_path
end
task :init, [:target] do |_, args|
options = find_build_target GCC_VERSION, args
env = {
'PATH' => "#{options.rootfs.realpath + 'bin'}:#{ENV['PATH']}"
}
sh env, 'riscv32-unknown-linux-gnu-gcc',
'-ffreestanding', '-static',
'-o', (options.tools + 'init').to_path,
'tools/init.c'
end
end
desc 'Build cross toolchain'
task :cross, [:target] => [
'cross:binutils',
'cross:gcc1',
'cross:headers',
'cross:kernel',
'cross:glibc',
'cross:gcc2',
'cross:init'
] do
end

5
rakelib/shared.rb Normal file
View File

@ -0,0 +1,5 @@
# This Source Code Form is subject to the terms of the Mozilla Public License,
# v. 2.0. If a copy of the MPL was not distributed with this file, You can
# obtain one at https://mozilla.org/MPL/2.0/. -}
TMP = Pathname.new('./build')

100
rakelib/tester.rake Normal file
View File

@ -0,0 +1,100 @@
# This Source Code Form is subject to the terms of the Mozilla Public License,
# v. 2.0. If a copy of the MPL was not distributed with this file, You can
# obtain one at https://mozilla.org/MPL/2.0/. -}
require 'open3'
require 'rake/clean'
require_relative 'shared'
CLEAN.include(TMP + 'riscv')
LINKER = 'build/rootfs/riscv32-unknown-linux-gnu/bin/ld'
AS = 'build/rootfs/riscv32-unknown-linux-gnu/bin/as'
namespace :test do
test_sources = FileList['tests/vm/*.elna', 'tests/vm/*.s']
compiler = `cabal list-bin elna`.strip
object_directory = TMP + 'riscv/tests'
root_directory = TMP + 'riscv/root'
executable_directory = root_directory + 'tests'
expectation_directory = root_directory + 'expectations'
init = TMP + 'riscv/root/init'
builtin = TMP + 'riscv/builtin.o'
directory root_directory
directory object_directory
directory executable_directory
directory expectation_directory
file builtin => ['tools/builtin.s', object_directory] do |task|
sh AS, '-o', task.name, task.prerequisites.first
end
test_files = test_sources.flat_map do |test_source|
test_basename = File.basename(test_source, '.*')
test_object = object_directory + test_basename.ext('.o')
file test_object => [test_source, object_directory] do |task|
case File.extname(task.prerequisites.first)
when '.s'
sh AS, '-mno-relax', '-o', task.name, task.prerequisites.first
when '.elna'
sh compiler, '--output', task.name, task.prerequisites.first
else
raise "Unknown source file extension #{task.prerequisites.first}"
end
end
test_executable = executable_directory + test_basename
file test_executable => [test_object, executable_directory, builtin] do |task|
objects = task.prerequisites.filter { |prerequisite| File.file? prerequisite }
sh LINKER, '-o', test_executable.to_path, *objects
end
expectation_name = test_basename.ext '.txt'
source_expectation = "tests/expectations/#{expectation_name}"
target_expectation = expectation_directory + expectation_name
file target_expectation => [source_expectation, expectation_directory] do
cp source_expectation, target_expectation
end
[test_executable, target_expectation]
end
file init => [root_directory] do |task|
cp (TMP + 'tools/init'), task.name
end
# Directories should come first.
test_files.unshift executable_directory, expectation_directory, init
file (TMP + 'riscv/root.cpio') => test_files do |task|
root_files = task.prerequisites
.map { |prerequisite| Pathname.new(prerequisite).relative_path_from(root_directory).to_path }
File.open task.name, 'wb' do |cpio_file|
cpio_options = {
chdir: root_directory.to_path
}
cpio_stream = Open3.popen2 'cpio', '-o', '--format=newc', cpio_options do |stdin, stdout, wait_thread|
stdin.write root_files.join("\n")
stdin.close
stdout.each { |chunk| cpio_file.write chunk }
wait_thread.value
end
end
end
task :vm => (TMP + 'riscv/root.cpio') do |task|
kernels = FileList.glob(TMP + 'tools/linux-*/arch/riscv/boot/Image')
sh 'qemu-system-riscv32',
'-nographic',
'-M', 'virt',
'-bios', 'default',
'-kernel', kernels.first,
'-append', 'quiet panic=1',
'-initrd', task.prerequisites.first,
'-no-reboot'
end
end

953
source.elna
View File

@ -1,953 +0,0 @@
const
SEEK_SET* = 0
SEEK_CUR* = 1
SEEK_END* = 2
TOKEN_IDENTIFIER* = 1
TOKEN_IF* = 2
TOKEN_THEN* = 3
TOKEN_ELSE* = 4
TOKEN_ELSIF* = 5
TOKEN_WHILE* = 6
TOKEN_DO* = 7
TOKEN_PROC* = 8
TOKEN_BEGIN* = 9
TOKEN_END* = 10
TOKEN_EXTERN* = 11
TOKEN_CONST* = 12
TOKEN_VAR* = 13
TOKEN_ARRAY* = 14
TOKEN_OF* = 15
TOKEN_TYPE* = 16
TOKEN_RECORD* = 17
TOKEN_UNION* = 18
TOKEN_POINTER* = 19
TOKEN_TO* = 20
TOKEN_BOOLEAN* = 21
TOKEN_NIL* = 22
TOKEN_AND* = 23
TOKEN_OR* = 24
TOKEN_NOT* = 25
TOKEN_RETURN* = 26
TOKEN_CAST* = 27
TOKEN_SHIFT_LEFT* = 28
TOKEN_SHIFT_RIGHT* = 29
TOKEN_LEFT_PAREN* = 30
TOKEN_RIGHT_PAREN* = 31
TOKEN_LEFT_SQUARE* = 32
TOKEN_RIGHT_SQUARE* = 33
TOKEN_GREATER_EQUAL* = 34
TOKEN_LESS_EQUAL* = 35
TOKEN_GREATER_THAN* = 36
TOKEN_LESS_THAN* = 37
TOKEN_NOT_EQUAL* = 38
TOKEN_EQUAL* = 39
TOKEN_SEMICOLON* = 40
TOKEN_DOT* = 41
TOKEN_COMMA* = 42
TOKEN_PLUS* = 43
TOKEN_MINUS* = 44
TOKEN_MULTIPLICATION* = 45
TOKEN_DIVISION* = 46
TOKEN_REMAINDER* = 47
TOKEN_ASSIGNMENT* = 48
TOKEN_COLON* = 49
TOKEN_HAT* = 50
TOKEN_AT* = 51
TOKEN_COMMENT* = 52
TOKEN_INTEGER* = 53
TOKEN_WORD* = 54
TOKEN_CHARACTER* = 55
TOKEN_STRING* = 56
TOKEN_DEFER* = 57
TOKEN_EXCLAMATION* = 58
type
Position* = record
line: Word
column: Word
end
Location* = record
first: Position
last: Position
end
SourceCode = record
position: Position
text: String
end
TokenValue* = union
int_value: Int
string_value: ^Char
string: String
boolean_value: Bool
char_value: Char
end
Token* = record
kind: Int
value: TokenValue
location: Location
end
FILE* = record end
CommandLine* = record
input: ^Char
tokenize: Bool
syntax_tree: Bool
end
Literal* = record
value: Int
end
ConstantDefinition* = record
name: ^Char
body: ^Literal
end
ConstantPart* = record
elements: ^^ConstantDefinition
count: Word
end
Program* = record
constants: ConstantPart
end
(*
External procedures.
*)
proc fopen(pathname: ^Char, mode: ^Char) -> ^FILE; extern
proc fclose(stream: ^FILE) -> Int; extern
proc fseek(stream: ^FILE, off: Int, whence: Int) -> Int; extern
proc rewind(stream: ^FILE); extern
proc ftell(stream: ^FILE) -> Int; extern
proc fread(ptr: ^Byte, size: Word, nmemb: Word, stream: ^FILE) -> Word; extern
proc write(fd: Int, buf: ^Byte, Word: Int) -> Int; extern
proc malloc(size: Word) -> ^Byte; extern
proc free(ptr: ^Byte); extern
proc calloc(nmemb: Word, size: Word) -> ^Byte; extern
proc realloc(ptr: ^Byte, size: Word) -> ^Byte; extern
proc memset(ptr: ^Char, c: Int, n: Int) -> ^Char; extern
proc strcmp(s1: ^Char, s2: ^Char) -> Int; extern
proc strncmp(s1: ^Char, s2: ^Char, n: Word) -> Int; extern
proc strncpy(dst: ^Char, src: ^Char, dsize: Word) -> ^Char; extern
proc strcpy(dst: ^Char, src: ^Char) -> ^Char; extern
proc strlen(ptr: ^Char) -> Word; extern
proc strtol(nptr: ^Char, endptr: ^^Char, base: Int) -> Int; extern
proc perror(s: ^Char); extern
proc exit(code: Int) -> !; extern
(*
Standard procedures.
*)
proc reallocarray(ptr: ^Byte, n: Word, size: Word) -> ^Byte;
begin
return realloc(ptr, n * size)
end
proc write_s(value: String);
begin
write(0, cast(value.ptr: ^Byte), cast(value.length: Int))
end
proc write_z(value: ^Char);
begin
write(0, cast(value: ^Byte), cast(strlen(value): Int))
end
proc write_b(value: Bool);
begin
if value then
write_s("true")
else
write_s("false")
end
end
proc write_c(value: Char);
begin
write(0, cast(@value: ^Byte), 1)
end
proc write_i(value: Int);
var
digit: Int
n: Word
buffer: [10]Char
begin
n := 10u
if value = 0 then
write_c('0')
end
while value <> 0 do
digit := value % 10
value := value / 10
buffer[n] := cast(cast('0': Int) + digit: Char)
n := n - 1u
end
while n < 10u do
n := n + 1u
write_c(buffer[n])
end
end
proc write_u(value: Word);
begin
write_i(cast(value: Int))
end
proc is_digit(c: Char) -> Bool;
begin
return cast(c: Int) >= cast('0': Int) and cast(c: Int) <= cast('9': Int)
end
proc is_alpha(c: Char) -> Bool;
begin
return cast(c: Int) >= cast('A': Int) and cast(c: Int) <= cast('z': Int)
end
proc is_alnum(c: Char) -> Bool;
begin
return is_digit(c) or is_alpha(c)
end
proc is_space(c: Char) -> Bool;
begin
return c = ' ' or c = '\n' or c = '\t'
end
proc substring(string: String, start: Word, count: Word) -> String;
begin
return String(string.ptr + start, count)
end
proc open_substring(string: String, start: Word) -> String;
begin
return substring(string, start, string.length - start)
end
proc string_dup(origin: String) -> String;
var
copy: ^Char
begin
copy := cast(malloc(origin.length): ^Char)
strncpy(copy, origin.ptr, origin.length)
return String(copy, origin.length)
end
(*
End of standard procedures.
*)
proc make_position() -> Position;
begin
return Position(1u, 1u)
end
proc read_source(filename: ^Char, result: ^String) -> Bool;
var
input_file: ^FILE
source_size: Int
input: ^Byte
begin
input_file := fopen(filename, "rb\0".ptr)
if input_file = nil then
return false
end
defer
fclose(input_file)
end
if fseek(input_file, 0, SEEK_END) <> 0 then
return false
end
source_size := ftell(input_file)
if source_size < 0 then
return false
end
rewind(input_file)
input := malloc(cast(source_size: Word))
if fread(input, cast(source_size: Word), 1u, input_file) <> 1u then
return false
end
result^ := String(cast(input: ^Char), cast(source_size: Word))
return true
end
proc escape_char(escape: Char, result: ^Char) -> Bool;
var
successful: Bool
begin
if escape = 'n' then
result^ := '\n'
successful := true
elsif escape = 'a' then
result^ := '\a'
successful := true
elsif escape = 'b' then
result^ := '\b'
successful := true
elsif escape = 't' then
result^ := '\t'
successful := true
elsif escape = 'f' then
result^ := '\f'
successful := true
elsif escape = 'r' then
result^ := '\r'
successful := true
elsif escape = 'v' then
result^ := '\v'
successful := true
elsif escape = '\\' then
result^ := '\\'
successful := true
elsif escape = '\'' then
result^ := '\''
successful := true
elsif escape = '"' then
result^ := '"'
successful := true
elsif escape = '?' then
result^ := '\?'
successful := true
elsif escape = '0' then
result^ := '\0'
successful := true
else
successful := false
end
return successful
end
proc advance_source(source_code: SourceCode, length: Word) -> SourceCode;
begin
source_code.text := open_substring(source_code.text, length)
source_code.position.column := source_code.position.column + length
return source_code
end
proc skip_spaces(source_code: SourceCode) -> SourceCode;
begin
while source_code.text.length > 0u and is_space(source_code.text[1u]) do
if source_code.text[1u] = '\n' then
source_code.position.line := source_code.position.line + 1u
source_code.position.column := 1u
else
source_code.position.column := source_code.position.column + 1u
end
source_code.text := open_substring(source_code.text, 1u)
end
return source_code
end
proc lex_identifier(source_code: ^SourceCode, token_content: ^String);
var
content_length: Word
begin
content_length := 0u
token_content^ := source_code^.text
while is_alnum(source_code^.text[1u]) or source_code^.text[1u] = '_' do
content_length := content_length + 1u
source_code^ := advance_source(source_code^, 1u)
end
token_content^ := substring(token_content^, 0u, content_length)
end
proc lex_comment(source_code: ^SourceCode, token_content: ^String) -> Bool;
var
content_length: Word
begin
content_length := 0u
token_content^ := source_code^.text
while source_code^.text.length > 1u do
if source_code^.text[1u] = '*' and source_code^.text[2u] = ')' then
source_code^ := advance_source(source_code^, 2u)
token_content^ := substring(token_content^, 0u, content_length)
return true
end
content_length := content_length + 1u
source_code^ := advance_source(source_code^, 1u)
end
return false
end
proc lex_character(input: ^Char, current_token: ^Token) -> ^Char;
begin
if input^ = '\\' then
input := input + 1
if escape_char(input^, @current_token^.value.char_value) then
input := input + 1
end
elsif input^ <> '\0' then
current_token^.value.char_value := input^
input := input + 1
end
return input
end
proc lex_string(input: ^Char, current_token: ^Token) -> ^Char;
var
token_end, constructed_string: ^Char
token_length: Word
is_valid: Bool
begin
token_end := input
while token_end^ <> '\0' and not ((token_end - 1)^ <> '\\' and token_end^ = '"') do
token_end := token_end + 1
end
if token_end^ <> '\"' then
return input
end
token_length := cast(token_end - input: Word)
current_token^.value.string_value := cast(calloc(token_length, 1u): ^Char)
is_valid := true
constructed_string := current_token^.value.string_value
while input < token_end and is_valid do
if input^ = '\\' then
input := input + 1
if escape_char(input^, constructed_string) then
input := input + 1
else
is_valid := false
end
elsif input^ <> '\0' then
constructed_string^ := input^
input := input + 1
end
constructed_string := constructed_string + 1
end
return token_end
end
proc print_tokens(tokens: ^Token, tokens_size: Word);
var
current_token: ^Token
i: Word
begin
i := 0u
while i < tokens_size do
current_token := tokens + i
if current_token^.kind = TOKEN_IF then
write_s("IF")
elsif current_token^.kind = TOKEN_THEN then
write_s("THEN")
elsif current_token^.kind = TOKEN_ELSE then
write_s("ELSE")
elsif current_token^.kind = TOKEN_ELSIF then
write_s("ELSIF")
elsif current_token^.kind = TOKEN_WHILE then
write_s("WHILE")
elsif current_token^.kind = TOKEN_DO then
write_s("DO")
elsif current_token^.kind = TOKEN_PROC then
write_s("PROC")
elsif current_token^.kind = TOKEN_BEGIN then
write_s("BEGIN")
elsif current_token^.kind = TOKEN_END then
write_s("END")
elsif current_token^.kind = TOKEN_EXTERN then
write_s("EXTERN")
elsif current_token^.kind = TOKEN_CONST then
write_s("CONST")
elsif current_token^.kind = TOKEN_VAR then
write_s("VAR")
elsif current_token^.kind = TOKEN_ARRAY then
write_s("ARRAY")
elsif current_token^.kind = TOKEN_OF then
write_s("OF")
elsif current_token^.kind = TOKEN_TYPE then
write_s("TYPE")
elsif current_token^.kind = TOKEN_RECORD then
write_s("RECORD")
elsif current_token^.kind = TOKEN_UNION then
write_s("UNION")
elsif current_token^.kind = TOKEN_POINTER then
write_s("POINTER")
elsif current_token^.kind = TOKEN_TO then
write_s("TO")
elsif current_token^.kind = TOKEN_BOOLEAN then
write_s("BOOLEAN<")
write_b(current_token^.value.boolean_value)
write_c('>')
elsif current_token^.kind = TOKEN_NIL then
write_s("NIL")
elsif current_token^.kind = TOKEN_AND then
write_s("AND")
elsif current_token^.kind = TOKEN_OR then
write_s("OR")
elsif current_token^.kind = TOKEN_NOT then
write_s("NOT")
elsif current_token^.kind = TOKEN_RETURN then
write_s("RETURN")
elsif current_token^.kind = TOKEN_CAST then
write_s("CAST")
elsif current_token^.kind = TOKEN_SHIFT_LEFT then
write_s("<<")
elsif current_token^.kind = TOKEN_SHIFT_RIGHT then
write_s(">>")
elsif current_token^.kind = TOKEN_IDENTIFIER then
write_c('<')
write_s(current_token^.value.string)
write_c('>')
elsif current_token^.kind = TOKEN_LEFT_PAREN then
write_s("(")
elsif current_token^.kind = TOKEN_RIGHT_PAREN then
write_s(")")
elsif current_token^.kind = TOKEN_LEFT_SQUARE then
write_s("[")
elsif current_token^.kind = TOKEN_RIGHT_SQUARE then
write_s("]")
elsif current_token^.kind = TOKEN_GREATER_EQUAL then
write_s(">=")
elsif current_token^.kind = TOKEN_LESS_EQUAL then
write_s("<=")
elsif current_token^.kind = TOKEN_GREATER_THAN then
write_s(">")
elsif current_token^.kind = TOKEN_LESS_THAN then
write_s("<")
elsif current_token^.kind = TOKEN_EQUAL then
write_s("=")
elsif current_token^.kind = TOKEN_NOT_EQUAL then
write_s("<>")
elsif current_token^.kind = TOKEN_SEMICOLON then
write_c(';')
elsif current_token^.kind = TOKEN_DOT then
write_c('.')
elsif current_token^.kind = TOKEN_COMMA then
write_c(',')
elsif current_token^.kind = TOKEN_PLUS then
write_c('+')
elsif current_token^.kind = TOKEN_MINUS then
write_c('-')
elsif current_token^.kind = TOKEN_MULTIPLICATION then
write_c('*')
elsif current_token^.kind = TOKEN_DIVISION then
write_c('/')
elsif current_token^.kind = TOKEN_REMAINDER then
write_c('%')
elsif current_token^.kind = TOKEN_ASSIGNMENT then
write_s(":=")
elsif current_token^.kind = TOKEN_COLON then
write_c(':')
elsif current_token^.kind = TOKEN_HAT then
write_c('^')
elsif current_token^.kind = TOKEN_AT then
write_c('@')
elsif current_token^.kind = TOKEN_COMMENT then
write_s("(* COMMENT *)")
elsif current_token^.kind = TOKEN_INTEGER then
write_c('<')
write_i(current_token^.value.int_value)
write_c('>')
elsif current_token^.kind = TOKEN_WORD then
write_c('<')
write_i(current_token^.value.int_value)
write_s("u>")
elsif current_token^.kind = TOKEN_CHARACTER then
write_c('<')
write_i(cast(current_token^.value.char_value: Int))
write_s("c>")
elsif current_token^.kind = TOKEN_STRING then
write_s("\"...\"")
elsif current_token^.kind = TOKEN_DEFER then
write_s("DEFER")
elsif current_token^.kind = TOKEN_EXCLAMATION then
write_c('!')
else
write_s("UNKNOWN<")
write_i(current_token^.kind)
write_c('>')
end
write_c(' ')
i := i + 1u
end
write_c('\n')
end
proc categorize_identifier(token_content: String) -> Token;
var
current_token: Token
begin
if "if" = token_content then
current_token.kind := TOKEN_IF
elsif "then" = token_content then
current_token.kind := TOKEN_THEN
elsif "else" = token_content then
current_token.kind := TOKEN_ELSE
elsif "elsif" = token_content then
current_token.kind := TOKEN_ELSIF
elsif "while" = token_content then
current_token.kind := TOKEN_WHILE
elsif "do" = token_content then
current_token.kind := TOKEN_DO
elsif "proc" = token_content then
current_token.kind := TOKEN_PROC
elsif "begin" = token_content then
current_token.kind := TOKEN_BEGIN
elsif "end" = token_content then
current_token.kind := TOKEN_END
elsif "extern" = token_content then
current_token.kind := TOKEN_EXTERN
elsif "const" = token_content then
current_token.kind := TOKEN_CONST
elsif "var" = token_content then
current_token.kind := TOKEN_VAR
elsif "array" = token_content then
current_token.kind := TOKEN_ARRAY
elsif "of" = token_content then
current_token.kind := TOKEN_OF
elsif "type" = token_content then
current_token.kind := TOKEN_TYPE
elsif "record" = token_content then
current_token.kind := TOKEN_RECORD
elsif "union" = token_content then
current_token.kind := TOKEN_UNION
elsif "pointer" = token_content then
current_token.kind := TOKEN_POINTER
elsif "to" = token_content then
current_token.kind := TOKEN_TO
elsif "true" = token_content then
current_token.kind := TOKEN_BOOLEAN
current_token.value.boolean_value := true
elsif "false" = token_content then
current_token.kind := TOKEN_BOOLEAN
current_token.value.boolean_value := false
elsif "nil" = token_content then
current_token.kind := TOKEN_NIL
elsif "and" = token_content then
current_token.kind := TOKEN_AND
elsif "or" = token_content then
current_token.kind := TOKEN_OR
elsif "not" = token_content then
current_token.kind := TOKEN_NOT
elsif "return" = token_content then
current_token.kind := TOKEN_RETURN
elsif "cast" = token_content then
current_token.kind := TOKEN_CAST
elsif "defer" = token_content then
current_token.kind := TOKEN_DEFER
else
current_token.kind := TOKEN_IDENTIFIER
current_token.value.string := string_dup(token_content)
end
return current_token
end
proc tokenize(source_code: SourceCode, tokens_size: ^Word) -> ^Token;
var
token_end: ^Char
tokens, current_token: ^Token
token_length: Word
first_char: Char
token_content: String
begin
tokens_size^ := 0u
tokens := nil
source_code := skip_spaces(source_code)
while source_code.text.length <> 0u do
tokens := cast(reallocarray(cast(tokens: ^Byte), tokens_size^ + 1u, Token.size): ^Token)
current_token := tokens + tokens_size^
first_char := source_code.text[1u]
if is_alpha(first_char) or first_char = '_' then
lex_identifier(@source_code, @token_content)
current_token^ := categorize_identifier(token_content)
elsif is_digit(first_char) then
token_end := nil
current_token^.value.int_value := strtol(source_code.text.ptr, @token_end, 10)
token_length := cast(token_end - source_code.text.ptr: Word)
if token_end^ = 'u' then
current_token^.kind := TOKEN_WORD
source_code := advance_source(source_code, token_length + 1u)
else
current_token^.kind := TOKEN_INTEGER
source_code := advance_source(source_code, token_length)
end
elsif first_char = '(' then
source_code := advance_source(source_code, 1u)
if source_code.text.length = 0u then
current_token^.kind := TOKEN_LEFT_PAREN
elsif source_code.text[1u] = '*' then
source_code := advance_source(source_code, 1u)
if lex_comment(@source_code, @token_content) then
current_token^.value.string := string_dup(token_content)
current_token^.kind := TOKEN_COMMENT
else
current_token^.kind := 0
end
else
current_token^.kind := TOKEN_LEFT_PAREN
end
elsif first_char = ')' then
current_token^.kind := TOKEN_RIGHT_PAREN
source_code := advance_source(source_code, 1u)
elsif first_char = '\'' then
token_end := lex_character(source_code.text.ptr + 1, current_token)
token_length := cast(token_end - source_code.text.ptr: Word)
if token_end^ = '\'' then
current_token^.kind := TOKEN_CHARACTER
source_code := advance_source(source_code, token_length + 1u)
else
source_code := advance_source(source_code, 1u)
end
elsif first_char = '"' then
token_end := lex_string(source_code.text.ptr + 1, current_token)
if token_end^ = '"' then
current_token^.kind := TOKEN_STRING
token_length := cast(token_end - source_code.text.ptr: Word)
source_code := advance_source(source_code, token_length + 1u)
end
elsif first_char = '[' then
current_token^.kind := TOKEN_LEFT_SQUARE
source_code := advance_source(source_code, 1u)
elsif first_char = ']' then
current_token^.kind := TOKEN_RIGHT_SQUARE
source_code := advance_source(source_code, 1u)
elsif first_char = '>' then
source_code := advance_source(source_code, 1u)
if source_code.text.length = 0u then
current_token^.kind := TOKEN_GREATER_THAN
elsif source_code.text[1u] = '=' then
current_token^.kind := TOKEN_GREATER_EQUAL
source_code := advance_source(source_code, 1u)
elsif source_code.text[1u] = '>' then
current_token^.kind := TOKEN_SHIFT_RIGHT
source_code := advance_source(source_code, 1u)
else
current_token^.kind := TOKEN_GREATER_THAN
end
elsif first_char = '<' then
source_code := advance_source(source_code, 1u)
if source_code.text.length = 0u then
current_token^.kind := TOKEN_LESS_THAN
elsif source_code.text[1u] = '=' then
current_token^.kind := TOKEN_LESS_EQUAL
source_code := advance_source(source_code, 1u)
elsif source_code.text[1u] = '<' then
current_token^.kind := TOKEN_SHIFT_LEFT
source_code := advance_source(source_code, 1u)
elsif source_code.text[1u] = '>' then
current_token^.kind := TOKEN_NOT_EQUAL
source_code := advance_source(source_code, 1u)
else
current_token^.kind := TOKEN_LESS_THAN
end
elsif first_char = '=' then
current_token^.kind := TOKEN_EQUAL
source_code := advance_source(source_code, 1u)
elsif first_char = ';' then
current_token^.kind := TOKEN_SEMICOLON
source_code := advance_source(source_code, 1u)
elsif first_char = '.' then
current_token^.kind := TOKEN_DOT
source_code := advance_source(source_code, 1u)
elsif first_char = ',' then
current_token^.kind := TOKEN_COMMA
source_code := advance_source(source_code, 1u)
elsif first_char = '+' then
current_token^.kind := TOKEN_PLUS
source_code := advance_source(source_code, 1u)
elsif first_char = '-' then
current_token^.kind := TOKEN_MINUS
source_code := advance_source(source_code, 1u)
elsif first_char = '*' then
current_token^.kind := TOKEN_MULTIPLICATION
source_code := advance_source(source_code, 1u)
elsif first_char = '/' then
current_token^.kind := TOKEN_DIVISION
source_code := advance_source(source_code, 1u)
elsif first_char = '%' then
current_token^.kind := TOKEN_REMAINDER
source_code := advance_source(source_code, 1u)
elsif first_char = ':' then
source_code := advance_source(source_code, 1u)
if source_code.text.length = 0u then
current_token^.kind := TOKEN_COLON
elsif source_code.text[1u] = '=' then
current_token^.kind := TOKEN_ASSIGNMENT
source_code := advance_source(source_code, 1u)
else
current_token^.kind := TOKEN_COLON
end
elsif first_char = '^' then
current_token^.kind := TOKEN_HAT
source_code := advance_source(source_code, 1u)
elsif first_char = '@' then
current_token^.kind := TOKEN_AT
source_code := advance_source(source_code, 1u)
elsif first_char = '!' then
current_token^.kind := TOKEN_EXCLAMATION
source_code := advance_source(source_code, 1u)
else
current_token^.kind := 0
source_code := advance_source(source_code, 1u)
end
if current_token^.kind <> 0 then
tokens_size^ := tokens_size^ + 1u
source_code := skip_spaces(source_code)
else
write_s("Lexical analysis error on \"")
write_c(first_char)
write_s("\".\n")
end
end
return tokens
end
proc parse_constant_definition(tokens: ^^Token,
tokens_size: ^Word) -> ^ConstantDefinition;
var
result: ^ConstantDefinition
begin
result := cast(calloc(1u, ConstantDefinition.size): ^ConstantDefinition)
result^.name := cast(malloc(strlen(tokens^^.value.string_value)): ^Char)
strcpy(result^.name, tokens^^.value.string_value)
tokens^ := tokens^ + 2u
tokens_size := tokens_size - 2u
write_z(result^.name)
write_c('\n')
tokens^ := tokens^ + 2u
tokens_size := tokens_size - 2u
return result
end
proc parse_program(tokens: ^^Token, tokens_size: ^Word) -> ^Program;
var
result: ^Program
current_constant: ^^ConstantDefinition
begin
result := cast(calloc(1u, Program.size): ^Program)
result^.constants.elements := nil
result^.constants.count := 0u
if tokens^^.kind = TOKEN_CONST then
tokens^ := tokens^ + 1
tokens_size^ := tokens_size^ - 1u
while tokens_size^ > 0u and tokens^^.kind = TOKEN_IDENTIFIER do
result^.constants.elements := cast(
reallocarray(
cast(result^.constants.elements: ^Byte),
result^.constants.count + 1u,
(^ConstantDefinition).size
) : ^^ConstantDefinition)
current_constant := result^.constants.elements + result^.constants.count
result^.constants.count := result^.constants.count + 1u
current_constant^ := parse_constant_definition(tokens, tokens_size)
if current_constant^ = nil then
return nil
end
end
end
end
proc parse_command_line*(argc: Int, argv: ^^Char) -> ^CommandLine;
var
parameter: ^^Char
i: Int
result: ^CommandLine
begin
i := 1
result := cast(malloc(CommandLine.size): ^CommandLine)
result^.tokenize := false
result^.syntax_tree := false
result^.input := nil
while i < argc do
parameter := argv + i
if strcmp(parameter^, "--tokenize\0".ptr) = 0 then
result^.tokenize := true
elsif strcmp(parameter^, "--syntax-tree\0".ptr) = 0 then
result^.syntax_tree := true
elsif parameter^^ <> '-' then
result^.input := parameter^
else
write_s("Fatal error: Unknown command line options:")
write_c(' ')
write_z(parameter^)
write_s(".\n")
return nil
end
i := i + 1
end
if result^.input = nil then
write_s("Fatal error: no input files.\n")
return nil
end
return result
end
proc process(argc: Int, argv: ^^Char) -> Int;
var
tokens: ^Token
tokens_size: Word
source_code: SourceCode
command_line: ^CommandLine
begin
command_line := parse_command_line(argc, argv)
if command_line = nil then
return 2
end
source_code.position := make_position()
if not read_source(command_line^.input, @source_code.text) then
perror(command_line^.input)
return 3
end
tokens := tokenize(source_code, @tokens_size)
if command_line^.tokenize then
print_tokens(tokens, tokens_size)
end
if command_line^.syntax_tree then
parse_program(@tokens, @tokens_size)
end
return 0
end
begin
exit(process(cast(count: Int), cast(parameters: ^^Char)))
end.

62
src/Main.hs Normal file
View File

@ -0,0 +1,62 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Main
( main
) where
import Language.Elna.Driver
( Driver(..)
, IntermediateStage(..)
, drive
)
import Language.Elna.Object.ElfCoder (elfObject)
import Language.Elna.Backend.Allocator (allocate)
import Language.Elna.Glue (glue)
import Language.Elna.Frontend.NameAnalysis (nameAnalysis)
import Language.Elna.Frontend.Parser (programP)
import Language.Elna.Frontend.TypeAnalysis (typeAnalysis)
import Language.Elna.RiscV.CodeGenerator (generateRiscV, riscVConfiguration)
import Language.Elna.RiscV.ElfWriter (riscv32Elf)
import Text.Megaparsec (runParser, errorBundlePretty)
import qualified Data.Text.IO as Text
import System.Exit (ExitCode(..), exitWith)
import Control.Exception (IOException, catch)
-- * Error codes
--
-- 1 - Command line parsing failed and other errors.
-- 2 - The input could not be read.
-- 3 - Parse error.
-- 4 - Name analysis error.
-- 5 - Type error.
-- 6 - Register allocation error.
main :: IO ()
main = drive >>= withCommandLine
where
withCommandLine driver@Driver{ input }
= catch (Text.readFile input) (printAndExit 2 :: IOException -> IO a)
>>= withParsedInput driver
. runParser programP input
withParsedInput driver@Driver{ intermediateStage } (Right program)
| Just ParseStage <- intermediateStage = pure ()
| otherwise
= either (printAndExit 4) (withSymbolTable driver program)
$ nameAnalysis program
withParsedInput _ (Left errorBundle)
= putStrLn (errorBundlePretty errorBundle)
>> exitWith (ExitFailure 3)
withSymbolTable driver@Driver{ intermediateStage } program symbolTable
| Just typeError <- typeAnalysis symbolTable program =
printAndExit 5 typeError
| Just ValidateStage <- intermediateStage = pure ()
| otherwise = either (printAndExit 6) (withTac driver)
$ allocate riscVConfiguration symbolTable
$ glue symbolTable program
withTac Driver{ intermediateStage, output } tac
| Just CodeGenStage <- intermediateStage = pure ()
| otherwise = elfObject output $ riscv32Elf $ generateRiscV tac
printAndExit :: Show b => forall a. Int -> b -> IO a
printAndExit failureCode e = print e >> exitWith (ExitFailure failureCode)

82
tests/Language/Elna/NameAnalysisSpec.hs Normal file
View File

@ -0,0 +1,82 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.NameAnalysisSpec
( spec
) where
import Data.Text (Text)
import Text.Megaparsec (runParser)
import Test.Hspec
( Spec
, describe
, expectationFailure
, it
, shouldBe
, shouldSatisfy
)
import Language.Elna.NameAnalysis (Error(..), nameAnalysis)
import Language.Elna.SymbolTable (Info(..), SymbolTable)
import qualified Language.Elna.SymbolTable as SymbolTable
import qualified Language.Elna.Parser as AST
import Language.Elna.Types (intType)
import Control.Exception (throwIO)
nameAnalysisOnText :: Text -> IO (Either Error SymbolTable)
nameAnalysisOnText sourceText = nameAnalysis
<$> either throwIO pure (runParser AST.programP "" sourceText)
spec :: Spec
spec = describe "nameAnalysis" $ do
it "adds type to the symbol table" $ do
let given = "type A = int;"
expected = Right $ Just $ TypeInfo intType
actual <- nameAnalysisOnText given
actual `shouldSatisfy` (expected ==) . fmap (SymbolTable.lookup "A")
it "errors when the aliased type is not defined" $ do
let given = "type A = B;"
expected = Left $ UndefinedTypeError "B"
actual <- nameAnalysisOnText given
actual `shouldBe` expected
it "errors if the aliased identifier is not a type" $ do
let given = "proc main() {} type A = main;"
expected = Left
$ UnexpectedTypeInfoError
$ ProcedureInfo mempty mempty
actual <- nameAnalysisOnText given
actual `shouldBe` expected
it "replaces the alias with an equivalent base type" $ do
let given = "type A = int; type B = A; type C = B;"
expected = Right $ Just $ TypeInfo intType
actual <- nameAnalysisOnText given
actual `shouldSatisfy` (expected ==) . fmap (SymbolTable.lookup "C")
it "puts parameters into the local symbol table" $ do
let given = "proc main(ref param: int) {}"
expected = SymbolTable.enter "param" (VariableInfo True intType) SymbolTable.empty
actual <- nameAnalysisOnText given
case SymbolTable.lookup "main" <$> actual of
Right lookupResult
| Just (ProcedureInfo localTable _) <- lookupResult ->
Just localTable `shouldBe` expected
_ -> expectationFailure "Procedure symbol not found"
it "puts variables into the local symbol table" $ do
let given = "proc main() { var var1: int; }"
expected = SymbolTable.enter "var1" (VariableInfo False intType) SymbolTable.empty
actual <- nameAnalysisOnText given
case SymbolTable.lookup "main" <$> actual of
Right lookupResult
| Just (ProcedureInfo localTable _) <- lookupResult ->
Just localTable `shouldBe` expected
_ -> expectationFailure "Procedure symbol not found"

146
tests/Language/Elna/ParserSpec.hs Normal file
View File

@ -0,0 +1,146 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module Language.Elna.ParserSpec
( spec
) where
import Test.Hspec (Spec, describe, it)
import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn, parseSatisfies)
import Language.Elna.Parser (programP)
import Text.Megaparsec (parse)
import Language.Elna.AST
( Declaration(..)
, Expression(..)
, Literal(..)
, Statement(..)
, Parameter(..)
, Program(..)
, VariableDeclaration(..)
, TypeExpression(..)
)
spec :: Spec
spec =
describe "programP" $ do
it "parses an empty main function" $
parse programP "" `shouldSucceedOn` "proc main() {}"
it "parses type definition for a type starting like array" $
let expected = Program [TypeDefinition "t" $ NamedType "arr"]
actual = parse programP "" "type t = arr;"
in actual `shouldParse` expected
it "parses array type definition" $
let expected = Program [TypeDefinition "t" $ ArrayType 10 (NamedType "int")]
actual = parse programP "" "type t = array[10] of int;"
in actual `shouldParse` expected
it "parses parameters" $
let given = "proc main(x: int) {}"
parameters = [Parameter "x" (NamedType "int") False]
expected = Program [ProcedureDefinition "main" parameters [] []]
actual = parse programP "" given
in actual `shouldParse` expected
it "parses ref parameters" $
let given = "proc main(x: int, ref y: boolean) {}"
parameters =
[ Parameter "x" (NamedType "int") False
, Parameter "y" (NamedType "boolean") True
]
expected = Program [ProcedureDefinition "main" parameters [] []]
actual = parse programP "" given
in actual `shouldParse` expected
it "parses variable declaration" $
let given = "proc main() { var x: int; }"
expected (Program [ProcedureDefinition _ _ variables _]) =
not $ null variables
expected _ = False
actual = parse programP "" given
in actual `parseSatisfies` expected
it "parses negation" $
let given = "proc main(x: int) { var y: int; y := -x; }"
parameters = pure $ Parameter "x" (NamedType "int") False
variables = pure
$ VariableDeclaration "y"
$ NamedType "int"
body = pure
$ AssignmentStatement (VariableExpression "y")
$ NegationExpression
$ VariableExpression "x"
expected = Program
[ProcedureDefinition "main" parameters variables body]
actual = parse programP "" given
in actual `shouldParse` expected
it "parses comparison with lower precedence than other binary operators" $
let given = "proc main() { var x: boolean; x := 1 + 2 = 3 * 4; }"
variables = pure
$ VariableDeclaration "x"
$ NamedType "boolean"
lhs = SumExpression (LiteralExpression (IntegerLiteral 1))
$ LiteralExpression (IntegerLiteral 2)
rhs = ProductExpression (LiteralExpression (IntegerLiteral 3))
$ LiteralExpression (IntegerLiteral 4)
body = pure
$ AssignmentStatement (VariableExpression "x")
$ EqualExpression lhs rhs
expected = Program
[ProcedureDefinition "main" [] variables body]
actual = parse programP "" given
in actual `shouldParse` expected
it "parses hexadecimals" $
let given = "proc main() { var x: int; x := 0x10; }"
variables = pure
$ VariableDeclaration "x"
$ NamedType "int"
body = pure
$ AssignmentStatement (VariableExpression "x")
$ LiteralExpression (HexadecimalLiteral 16)
expected = Program
[ProcedureDefinition "main" [] variables body]
actual = parse programP "" given
in actual `shouldParse` expected
it "parses procedure calls" $
let given = "proc main() { f('c'); }"
body = pure
$ CallStatement "f" [LiteralExpression (CharacterLiteral 99)]
expected = Program
[ProcedureDefinition "main" [] [] body]
actual = parse programP "" given
in actual `shouldParse` expected
it "parses an if statement" $
let given = "proc main() { if (true) ; }"
body = pure
$ IfStatement (LiteralExpression $ BooleanLiteral True) EmptyStatement Nothing
expected = Program
[ProcedureDefinition "main" [] [] body]
actual = parse programP "" given
in actual `shouldParse` expected
it "associates else with the nearst if statement" $
let given = "proc main() { if (true) if (false) ; else ; }"
if' = IfStatement (LiteralExpression $ BooleanLiteral False) EmptyStatement
$ Just EmptyStatement
body = pure
$ IfStatement (LiteralExpression $ BooleanLiteral True) if' Nothing
expected = Program
[ProcedureDefinition "main" [] [] body]
actual = parse programP "" given
in actual `shouldParse` expected
it "parses a while statement" $
let given = "proc main() { while (true) ; }"
body = pure
$ WhileStatement (LiteralExpression $ BooleanLiteral True) EmptyStatement
expected = Program
[ProcedureDefinition "main" [] [] body]
actual = parse programP "" given
in actual `shouldParse` expected

5
tests/Spec.hs Normal file
View File

@ -0,0 +1,5 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

1
tests/expectations/add_products.txt Normal file
View File

@ -0,0 +1 @@
38

1
tests/expectations/add_to_variable.txt Normal file
View File

@ -0,0 +1 @@
58

1
tests/expectations/array_element_assignment.txt Normal file
View File

@ -0,0 +1 @@
5

2
tests/expectations/array_with_variable_index.txt Normal file
View File

@ -0,0 +1,2 @@
5
7

1
tests/expectations/define_variable.txt Normal file
View File

@ -0,0 +1 @@
58

1
tests/expectations/exit_between_statements.txt Normal file
View File

@ -0,0 +1 @@
c

1
tests/expectations/parse_negative_numbers.txt Normal file
View File

@ -0,0 +1 @@
-8

1
tests/expectations/print0.txt Normal file
View File

@ -0,0 +1 @@
0

1
tests/expectations/print_2_digits.txt Normal file
View File

@ -0,0 +1 @@
13

2
tests/expectations/print_2_statements.txt Normal file
View File

@ -0,0 +1,2 @@
13
2097150

1
tests/expectations/print_after_loop.txt Normal file
View File

@ -0,0 +1 @@
2

2
tests/expectations/print_array_element.txt Normal file
View File

@ -0,0 +1,2 @@
5
7

1
tests/expectations/print_char.txt Normal file
View File

@ -0,0 +1 @@
x

2
tests/expectations/print_in_proc.txt Normal file
View File

@ -0,0 +1,2 @@
14
8

1
tests/expectations/print_more_20_bits.txt Normal file
View File

@ -0,0 +1 @@
2097150

1
tests/expectations/print_negate.txt Normal file
View File

@ -0,0 +1 @@
-8

1
tests/expectations/print_product.txt Normal file
View File

@ -0,0 +1 @@
1000

1
tests/expectations/print_subtraction.txt Normal file
View File

@ -0,0 +1 @@
-8

1
tests/expectations/print_sum.txt Normal file
View File

@ -0,0 +1 @@
18

1
tests/expectations/printi_hex.txt Normal file
View File

@ -0,0 +1 @@
129

1
tests/expectations/printi_if.txt Normal file
View File

@ -0,0 +1 @@
3

1
tests/expectations/printi_if_greater.txt Normal file
View File

@ -0,0 +1 @@
5

1
tests/expectations/printi_if_greater_equal.txt Normal file
View File

@ -0,0 +1 @@
5

1
tests/expectations/printi_if_less.txt Normal file
View File

@ -0,0 +1 @@
3

1
tests/expectations/printi_if_less_equal.txt Normal file
View File

@ -0,0 +1 @@
3

1
tests/expectations/printi_if_not.txt Normal file
View File

@ -0,0 +1 @@
3

2
tests/expectations/printi_if_not_compound.txt Normal file
View File

@ -0,0 +1,2 @@
3
7

1
tests/expectations/printi_negative_hex.txt Normal file
View File

@ -0,0 +1 @@
-129

1
tests/expectations/printi_quotient.txt Normal file
View File

@ -0,0 +1 @@
2

1
tests/expectations/printi_signed_hex.txt Normal file
View File

@ -0,0 +1 @@
129

2
tests/expectations/two_variables.txt Normal file
View File

@ -0,0 +1,2 @@
58
28

3
tests/vm/add_products.elna Normal file
View File

@ -0,0 +1,3 @@
proc main() {
printi(2 * 3 + 4 * 8);
}

6
tests/vm/add_to_variable.elna Normal file
View File

@ -0,0 +1,6 @@
proc main() {
var i: int;
i := 28;
printi(i + 30);
}

6
tests/vm/array_element_assignment.elna Normal file
View File

@ -0,0 +1,6 @@
proc main() {
var a: array[1] of int;
a[0] := 5;
printi(a[0]);
}

11
tests/vm/array_with_variable_index.elna Normal file
View File

@ -0,0 +1,11 @@
proc main() {
var a: array[2] of int;
var i: int;
i := 1;
a[0] := 5;
a[i] := 7;
printi(a[0]);
printi(a[i]);
}

6
tests/vm/define_variable.elna Normal file
View File

@ -0,0 +1,6 @@
proc main() {
var i: int;
i := 58;
printi(i);
}

5
tests/vm/exit_between_statements.elna Normal file
View File

@ -0,0 +1,5 @@
proc main() {
printc('c');
exit();
printi(1234);
}

3
tests/vm/parse_negative_numbers.elna Normal file
View File

@ -0,0 +1,3 @@
proc main() {
printi(-8);
}

3
tests/vm/print0.elna Normal file
View File

@ -0,0 +1,3 @@
proc main() {
printi(0);
}

3
tests/vm/print_2_digits.elna Normal file
View File

@ -0,0 +1,3 @@
proc main() {
printi(13);
}

4
tests/vm/print_2_statements.elna Normal file
View File

@ -0,0 +1,4 @@
proc main() {
printi(13);
printi(2097150);
}

9
tests/vm/print_after_loop.elna Normal file
View File

@ -0,0 +1,9 @@
proc main() {
var x: int;
x := 0;
while (x < 2) {
x := x + 1;
}
printi(x);
}

8
tests/vm/print_array_element.elna Normal file
View File

@ -0,0 +1,8 @@
proc main() {
var a: array[2] of int;
a[0] := 5;
a[1] := 7;
printi(a[0]);
printi(a[1]);
}

Some files were not shown because too many files have changed in this diff Show More