Compare commits
No commits in common. "modula2" and "haskell" have entirely different histories.
7
.gitignore
vendored
7
.gitignore
vendored
@ -1,3 +1,6 @@
|
||||
a.out
|
||||
/boot/
|
||||
/build/
|
||||
.cache/
|
||||
CMakeFiles/
|
||||
CMakeCache.txt
|
||||
node_modules/
|
||||
/dist-newstyle/
|
||||
|
||||
1
.ruby-version
Normal file
1
.ruby-version
Normal file
@ -0,0 +1 @@
|
||||
3.3.6
|
||||
373
LICENSE
Normal file
373
LICENSE
Normal file
@ -0,0 +1,373 @@
|
||||
Mozilla Public License Version 2.0
|
||||
==================================
|
||||
|
||||
1. Definitions
|
||||
--------------
|
||||
|
||||
1.1. "Contributor"
|
||||
means each individual or legal entity that creates, contributes to
|
||||
the creation of, or owns Covered Software.
|
||||
|
||||
1.2. "Contributor Version"
|
||||
means the combination of the Contributions of others (if any) used
|
||||
by a Contributor and that particular Contributor's Contribution.
|
||||
|
||||
1.3. "Contribution"
|
||||
means Covered Software of a particular Contributor.
|
||||
|
||||
1.4. "Covered Software"
|
||||
means Source Code Form to which the initial Contributor has attached
|
||||
the notice in Exhibit A, the Executable Form of such Source Code
|
||||
Form, and Modifications of such Source Code Form, in each case
|
||||
including portions thereof.
|
||||
|
||||
1.5. "Incompatible With Secondary Licenses"
|
||||
means
|
||||
|
||||
(a) that the initial Contributor has attached the notice described
|
||||
in Exhibit B to the Covered Software; or
|
||||
|
||||
(b) that the Covered Software was made available under the terms of
|
||||
version 1.1 or earlier of the License, but not also under the
|
||||
terms of a Secondary License.
|
||||
|
||||
1.6. "Executable Form"
|
||||
means any form of the work other than Source Code Form.
|
||||
|
||||
1.7. "Larger Work"
|
||||
means a work that combines Covered Software with other material, in
|
||||
a separate file or files, that is not Covered Software.
|
||||
|
||||
1.8. "License"
|
||||
means this document.
|
||||
|
||||
1.9. "Licensable"
|
||||
means having the right to grant, to the maximum extent possible,
|
||||
whether at the time of the initial grant or subsequently, any and
|
||||
all of the rights conveyed by this License.
|
||||
|
||||
1.10. "Modifications"
|
||||
means any of the following:
|
||||
|
||||
(a) any file in Source Code Form that results from an addition to,
|
||||
deletion from, or modification of the contents of Covered
|
||||
Software; or
|
||||
|
||||
(b) any new file in Source Code Form that contains any Covered
|
||||
Software.
|
||||
|
||||
1.11. "Patent Claims" of a Contributor
|
||||
means any patent claim(s), including without limitation, method,
|
||||
process, and apparatus claims, in any patent Licensable by such
|
||||
Contributor that would be infringed, but for the grant of the
|
||||
License, by the making, using, selling, offering for sale, having
|
||||
made, import, or transfer of either its Contributions or its
|
||||
Contributor Version.
|
||||
|
||||
1.12. "Secondary License"
|
||||
means either the GNU General Public License, Version 2.0, the GNU
|
||||
Lesser General Public License, Version 2.1, the GNU Affero General
|
||||
Public License, Version 3.0, or any later versions of those
|
||||
licenses.
|
||||
|
||||
1.13. "Source Code Form"
|
||||
means the form of the work preferred for making modifications.
|
||||
|
||||
1.14. "You" (or "Your")
|
||||
means an individual or a legal entity exercising rights under this
|
||||
License. For legal entities, "You" includes any entity that
|
||||
controls, is controlled by, or is under common control with You. For
|
||||
purposes of this definition, "control" means (a) the power, direct
|
||||
or indirect, to cause the direction or management of such entity,
|
||||
whether by contract or otherwise, or (b) ownership of more than
|
||||
fifty percent (50%) of the outstanding shares or beneficial
|
||||
ownership of such entity.
|
||||
|
||||
2. License Grants and Conditions
|
||||
--------------------------------
|
||||
|
||||
2.1. Grants
|
||||
|
||||
Each Contributor hereby grants You a world-wide, royalty-free,
|
||||
non-exclusive license:
|
||||
|
||||
(a) under intellectual property rights (other than patent or trademark)
|
||||
Licensable by such Contributor to use, reproduce, make available,
|
||||
modify, display, perform, distribute, and otherwise exploit its
|
||||
Contributions, either on an unmodified basis, with Modifications, or
|
||||
as part of a Larger Work; and
|
||||
|
||||
(b) under Patent Claims of such Contributor to make, use, sell, offer
|
||||
for sale, have made, import, and otherwise transfer either its
|
||||
Contributions or its Contributor Version.
|
||||
|
||||
2.2. Effective Date
|
||||
|
||||
The licenses granted in Section 2.1 with respect to any Contribution
|
||||
become effective for each Contribution on the date the Contributor first
|
||||
distributes such Contribution.
|
||||
|
||||
2.3. Limitations on Grant Scope
|
||||
|
||||
The licenses granted in this Section 2 are the only rights granted under
|
||||
this License. No additional rights or licenses will be implied from the
|
||||
distribution or licensing of Covered Software under this License.
|
||||
Notwithstanding Section 2.1(b) above, no patent license is granted by a
|
||||
Contributor:
|
||||
|
||||
(a) for any code that a Contributor has removed from Covered Software;
|
||||
or
|
||||
|
||||
(b) for infringements caused by: (i) Your and any other third party's
|
||||
modifications of Covered Software, or (ii) the combination of its
|
||||
Contributions with other software (except as part of its Contributor
|
||||
Version); or
|
||||
|
||||
(c) under Patent Claims infringed by Covered Software in the absence of
|
||||
its Contributions.
|
||||
|
||||
This License does not grant any rights in the trademarks, service marks,
|
||||
or logos of any Contributor (except as may be necessary to comply with
|
||||
the notice requirements in Section 3.4).
|
||||
|
||||
2.4. Subsequent Licenses
|
||||
|
||||
No Contributor makes additional grants as a result of Your choice to
|
||||
distribute the Covered Software under a subsequent version of this
|
||||
License (see Section 10.2) or under the terms of a Secondary License (if
|
||||
permitted under the terms of Section 3.3).
|
||||
|
||||
2.5. Representation
|
||||
|
||||
Each Contributor represents that the Contributor believes its
|
||||
Contributions are its original creation(s) or it has sufficient rights
|
||||
to grant the rights to its Contributions conveyed by this License.
|
||||
|
||||
2.6. Fair Use
|
||||
|
||||
This License is not intended to limit any rights You have under
|
||||
applicable copyright doctrines of fair use, fair dealing, or other
|
||||
equivalents.
|
||||
|
||||
2.7. Conditions
|
||||
|
||||
Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted
|
||||
in Section 2.1.
|
||||
|
||||
3. Responsibilities
|
||||
-------------------
|
||||
|
||||
3.1. Distribution of Source Form
|
||||
|
||||
All distribution of Covered Software in Source Code Form, including any
|
||||
Modifications that You create or to which You contribute, must be under
|
||||
the terms of this License. You must inform recipients that the Source
|
||||
Code Form of the Covered Software is governed by the terms of this
|
||||
License, and how they can obtain a copy of this License. You may not
|
||||
attempt to alter or restrict the recipients' rights in the Source Code
|
||||
Form.
|
||||
|
||||
3.2. Distribution of Executable Form
|
||||
|
||||
If You distribute Covered Software in Executable Form then:
|
||||
|
||||
(a) such Covered Software must also be made available in Source Code
|
||||
Form, as described in Section 3.1, and You must inform recipients of
|
||||
the Executable Form how they can obtain a copy of such Source Code
|
||||
Form by reasonable means in a timely manner, at a charge no more
|
||||
than the cost of distribution to the recipient; and
|
||||
|
||||
(b) You may distribute such Executable Form under the terms of this
|
||||
License, or sublicense it under different terms, provided that the
|
||||
license for the Executable Form does not attempt to limit or alter
|
||||
the recipients' rights in the Source Code Form under this License.
|
||||
|
||||
3.3. Distribution of a Larger Work
|
||||
|
||||
You may create and distribute a Larger Work under terms of Your choice,
|
||||
provided that You also comply with the requirements of this License for
|
||||
the Covered Software. If the Larger Work is a combination of Covered
|
||||
Software with a work governed by one or more Secondary Licenses, and the
|
||||
Covered Software is not Incompatible With Secondary Licenses, this
|
||||
License permits You to additionally distribute such Covered Software
|
||||
under the terms of such Secondary License(s), so that the recipient of
|
||||
the Larger Work may, at their option, further distribute the Covered
|
||||
Software under the terms of either this License or such Secondary
|
||||
License(s).
|
||||
|
||||
3.4. Notices
|
||||
|
||||
You may not remove or alter the substance of any license notices
|
||||
(including copyright notices, patent notices, disclaimers of warranty,
|
||||
or limitations of liability) contained within the Source Code Form of
|
||||
the Covered Software, except that You may alter any license notices to
|
||||
the extent required to remedy known factual inaccuracies.
|
||||
|
||||
3.5. Application of Additional Terms
|
||||
|
||||
You may choose to offer, and to charge a fee for, warranty, support,
|
||||
indemnity or liability obligations to one or more recipients of Covered
|
||||
Software. However, You may do so only on Your own behalf, and not on
|
||||
behalf of any Contributor. You must make it absolutely clear that any
|
||||
such warranty, support, indemnity, or liability obligation is offered by
|
||||
You alone, and You hereby agree to indemnify every Contributor for any
|
||||
liability incurred by such Contributor as a result of warranty, support,
|
||||
indemnity or liability terms You offer. You may include additional
|
||||
disclaimers of warranty and limitations of liability specific to any
|
||||
jurisdiction.
|
||||
|
||||
4. Inability to Comply Due to Statute or Regulation
|
||||
---------------------------------------------------
|
||||
|
||||
If it is impossible for You to comply with any of the terms of this
|
||||
License with respect to some or all of the Covered Software due to
|
||||
statute, judicial order, or regulation then You must: (a) comply with
|
||||
the terms of this License to the maximum extent possible; and (b)
|
||||
describe the limitations and the code they affect. Such description must
|
||||
be placed in a text file included with all distributions of the Covered
|
||||
Software under this License. Except to the extent prohibited by statute
|
||||
or regulation, such description must be sufficiently detailed for a
|
||||
recipient of ordinary skill to be able to understand it.
|
||||
|
||||
5. Termination
|
||||
--------------
|
||||
|
||||
5.1. The rights granted under this License will terminate automatically
|
||||
if You fail to comply with any of its terms. However, if You become
|
||||
compliant, then the rights granted under this License from a particular
|
||||
Contributor are reinstated (a) provisionally, unless and until such
|
||||
Contributor explicitly and finally terminates Your grants, and (b) on an
|
||||
ongoing basis, if such Contributor fails to notify You of the
|
||||
non-compliance by some reasonable means prior to 60 days after You have
|
||||
come back into compliance. Moreover, Your grants from a particular
|
||||
Contributor are reinstated on an ongoing basis if such Contributor
|
||||
notifies You of the non-compliance by some reasonable means, this is the
|
||||
first time You have received notice of non-compliance with this License
|
||||
from such Contributor, and You become compliant prior to 30 days after
|
||||
Your receipt of the notice.
|
||||
|
||||
5.2. If You initiate litigation against any entity by asserting a patent
|
||||
infringement claim (excluding declaratory judgment actions,
|
||||
counter-claims, and cross-claims) alleging that a Contributor Version
|
||||
directly or indirectly infringes any patent, then the rights granted to
|
||||
You by any and all Contributors for the Covered Software under Section
|
||||
2.1 of this License shall terminate.
|
||||
|
||||
5.3. In the event of termination under Sections 5.1 or 5.2 above, all
|
||||
end user license agreements (excluding distributors and resellers) which
|
||||
have been validly granted by You or Your distributors under this License
|
||||
prior to termination shall survive termination.
|
||||
|
||||
************************************************************************
|
||||
* *
|
||||
* 6. Disclaimer of Warranty *
|
||||
* ------------------------- *
|
||||
* *
|
||||
* Covered Software is provided under this License on an "as is" *
|
||||
* basis, without warranty of any kind, either expressed, implied, or *
|
||||
* statutory, including, without limitation, warranties that the *
|
||||
* Covered Software is free of defects, merchantable, fit for a *
|
||||
* particular purpose or non-infringing. The entire risk as to the *
|
||||
* quality and performance of the Covered Software is with You. *
|
||||
* Should any Covered Software prove defective in any respect, You *
|
||||
* (not any Contributor) assume the cost of any necessary servicing, *
|
||||
* repair, or correction. This disclaimer of warranty constitutes an *
|
||||
* essential part of this License. No use of any Covered Software is *
|
||||
* authorized under this License except under this disclaimer. *
|
||||
* *
|
||||
************************************************************************
|
||||
|
||||
************************************************************************
|
||||
* *
|
||||
* 7. Limitation of Liability *
|
||||
* -------------------------- *
|
||||
* *
|
||||
* Under no circumstances and under no legal theory, whether tort *
|
||||
* (including negligence), contract, or otherwise, shall any *
|
||||
* Contributor, or anyone who distributes Covered Software as *
|
||||
* permitted above, be liable to You for any direct, indirect, *
|
||||
* special, incidental, or consequential damages of any character *
|
||||
* including, without limitation, damages for lost profits, loss of *
|
||||
* goodwill, work stoppage, computer failure or malfunction, or any *
|
||||
* and all other commercial damages or losses, even if such party *
|
||||
* shall have been informed of the possibility of such damages. This *
|
||||
* limitation of liability shall not apply to liability for death or *
|
||||
* personal injury resulting from such party's negligence to the *
|
||||
* extent applicable law prohibits such limitation. Some *
|
||||
* jurisdictions do not allow the exclusion or limitation of *
|
||||
* incidental or consequential damages, so this exclusion and *
|
||||
* limitation may not apply to You. *
|
||||
* *
|
||||
************************************************************************
|
||||
|
||||
8. Litigation
|
||||
-------------
|
||||
|
||||
Any litigation relating to this License may be brought only in the
|
||||
courts of a jurisdiction where the defendant maintains its principal
|
||||
place of business and such litigation shall be governed by laws of that
|
||||
jurisdiction, without reference to its conflict-of-law provisions.
|
||||
Nothing in this Section shall prevent a party's ability to bring
|
||||
cross-claims or counter-claims.
|
||||
|
||||
9. Miscellaneous
|
||||
----------------
|
||||
|
||||
This License represents the complete agreement concerning the subject
|
||||
matter hereof. If any provision of this License is held to be
|
||||
unenforceable, such provision shall be reformed only to the extent
|
||||
necessary to make it enforceable. Any law or regulation which provides
|
||||
that the language of a contract shall be construed against the drafter
|
||||
shall not be used to construe this License against a Contributor.
|
||||
|
||||
10. Versions of the License
|
||||
---------------------------
|
||||
|
||||
10.1. New Versions
|
||||
|
||||
Mozilla Foundation is the license steward. Except as provided in Section
|
||||
10.3, no one other than the license steward has the right to modify or
|
||||
publish new versions of this License. Each version will be given a
|
||||
distinguishing version number.
|
||||
|
||||
10.2. Effect of New Versions
|
||||
|
||||
You may distribute the Covered Software under the terms of the version
|
||||
of the License under which You originally received the Covered Software,
|
||||
or under the terms of any subsequent version published by the license
|
||||
steward.
|
||||
|
||||
10.3. Modified Versions
|
||||
|
||||
If you create software not governed by this License, and you want to
|
||||
create a new license for such software, you may create and use a
|
||||
modified version of this License if you rename the license and remove
|
||||
any references to the name of the license steward (except to note that
|
||||
such modified license differs from this License).
|
||||
|
||||
10.4. Distributing Source Code Form that is Incompatible With Secondary
|
||||
Licenses
|
||||
|
||||
If You choose to distribute Source Code Form that is Incompatible With
|
||||
Secondary Licenses under the terms of this version of the License, the
|
||||
notice described in Exhibit B of this License must be attached.
|
||||
|
||||
Exhibit A - Source Code Form License Notice
|
||||
-------------------------------------------
|
||||
|
||||
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 http://mozilla.org/MPL/2.0/.
|
||||
|
||||
If it is not possible or desirable to put the notice in a particular
|
||||
file, then You may include the notice in a location (such as a LICENSE
|
||||
file in a relevant directory) where a recipient would be likely to look
|
||||
for such a notice.
|
||||
|
||||
You may add additional accurate notices of copyright ownership.
|
||||
|
||||
Exhibit B - "Incompatible With Secondary Licenses" Notice
|
||||
---------------------------------------------------------
|
||||
|
||||
This Source Code Form is "Incompatible With Secondary Licenses", as
|
||||
defined by the Mozilla Public License, v. 2.0.
|
||||
37
README
Normal file
37
README
Normal 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.
|
||||
63
README.md
63
README.md
@ -1,63 +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
|
||||
|
||||
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 ")";
|
||||
|
||||
## 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`.
|
||||
141
Rakefile
141
Rakefile
@ -1,141 +0,0 @@
|
||||
require 'pathname'
|
||||
require 'rake/clean'
|
||||
require 'open3'
|
||||
|
||||
M2C = 'gm2' # Modula-2 compiler.
|
||||
|
||||
stage_compiler = Pathname.new 'build/stage1/elna'
|
||||
|
||||
directory 'build/stage1'
|
||||
directory 'build/source'
|
||||
directory 'build/self'
|
||||
|
||||
CLEAN.include 'build'
|
||||
|
||||
rule(/build\/stage1\/.+\.o$/ => ->(file) {
|
||||
path = Pathname.new('boot/stage1/source') + Pathname.new(file).basename
|
||||
|
||||
['build/stage1', path.sub_ext('.def'), path.sub_ext('.mod')]
|
||||
}) do |t|
|
||||
sources = t.prerequisites.filter { |f| f.end_with? '.mod' }
|
||||
|
||||
sh M2C, '-c', '-I', 'boot/stage1/source', '-o', t.name, *sources
|
||||
end
|
||||
|
||||
file 'build/stage1/elna' => FileList['boot/stage1/source/*'].map { |file|
|
||||
File.join 'build', 'stage1', Pathname.new(file).basename.sub_ext('.o')
|
||||
} do |t|
|
||||
sh M2C, '-o', t.name, *t.prerequisites
|
||||
end
|
||||
|
||||
file 'build/stage1/Compiler.o' => ['build/stage1', 'boot/stage1/source/Compiler.mod'] do |t|
|
||||
sources = t.prerequisites.filter { |f| f.end_with? '.mod' }
|
||||
|
||||
sh M2C, '-fscaffold-main', '-c', '-I', 'boot/stage1/source', '-o', t.name, *sources
|
||||
end
|
||||
|
||||
['source', 'self'].each do |sub|
|
||||
rule(/build\/#{sub}\/.+\.mod$/ => [
|
||||
"build/#{sub}", stage_compiler.to_path,
|
||||
->(file) { File.join('source', Pathname.new(file).basename.sub_ext('.elna')) }
|
||||
]) do |t|
|
||||
sources, compiler = t.prerequisites
|
||||
.reject { |f| File.directory? f }
|
||||
.partition { |f| f.end_with? '.elna' }
|
||||
|
||||
File.open t.name, 'w' do |output|
|
||||
compiler_command = compiler + sources
|
||||
|
||||
puts
|
||||
puts(compiler_command * ' ')
|
||||
|
||||
Open3.popen2(*compiler_command) do |cl_in, cl_out|
|
||||
cl_in.close
|
||||
|
||||
IO.copy_stream cl_out, output
|
||||
cl_out.close
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
rule(/build\/#{sub}\/.+\.o$/ => ->(file) {
|
||||
path = Pathname.new(file).relative_path_from('build')
|
||||
result = []
|
||||
|
||||
result << File.join('source', path.basename.sub_ext('.def'))
|
||||
result << File.join('build', path.sub_ext('.mod'))
|
||||
}) do |t|
|
||||
sources = t.prerequisites.filter { |f| f.end_with? '.mod' }
|
||||
|
||||
sh M2C, '-c', '-I', 'source', '-o', t.name, *sources
|
||||
end
|
||||
|
||||
file "build/#{sub}/Compiler.o" => ["build/#{sub}/Compiler.mod"] do |t|
|
||||
sh M2C, '-fscaffold-main', '-c', '-I', 'source', '-o', t.name, *t.prerequisites
|
||||
end
|
||||
stage_compiler = Pathname.new('build') + sub + 'elna'
|
||||
|
||||
file stage_compiler => FileList["source/*.elna"].map { |file|
|
||||
File.join 'build', sub, Pathname.new(file).basename.sub_ext('.o')
|
||||
} do |t|
|
||||
sh M2C, '-o', t.name, *t.prerequisites
|
||||
end
|
||||
end
|
||||
|
||||
task default: 'build/self/elna'
|
||||
task default: 'build/self/Compiler.mod'
|
||||
task default: 'source/Compiler.elna'
|
||||
task :default do |t|
|
||||
exe, previous_output, source = t.prerequisites
|
||||
|
||||
exe_arguments = [exe, source]
|
||||
diff_arguments = ['diff', '-Nur', '--text', previous_output, '-']
|
||||
|
||||
puts [exe, diff_arguments * ' '].join(' | ')
|
||||
Open3.pipeline exe_arguments, diff_arguments
|
||||
end
|
||||
|
||||
task :backport do
|
||||
FileList['source/*.elna'].each do |file|
|
||||
source_path = Pathname.new file
|
||||
source = File.read source_path
|
||||
current_procedure = nil
|
||||
target = ''
|
||||
module_name = source_path.basename.sub_ext('')
|
||||
|
||||
source
|
||||
.gsub(/^(var|type|const|begin)/) { |match| match.upcase }
|
||||
.gsub(/\b(record|nil|or|false|true)\b/) { |match| match.upcase }
|
||||
.gsub(/proc\(/, 'PROCEDURE(')
|
||||
.gsub(/ & /, ' AND ')
|
||||
.gsub(/ -> /, ': ')
|
||||
.gsub(/program;/, "MODULE #{module_name};")
|
||||
.gsub(/module;/, "IMPLEMENTATION MODULE #{module_name};")
|
||||
.gsub(/end\./, "END #{module_name}.")
|
||||
.gsub(/([[:space:]]*)end(;?)$/, '\1END\2')
|
||||
.gsub(/^([[:space:]]*)(while|return|if)\b/) { |match| match.upcase }
|
||||
.gsub(/^from ([[:alnum:]]+) import/, 'FROM \1 IMPORT')
|
||||
.gsub(/ \^([[:alnum:]])/, ' POINTER TO \1')
|
||||
.gsub(/(then|do)$/) { |match| match.upcase }
|
||||
.gsub(/(:|=) \[([[:digit:]]+)\]/, '\1 ARRAY[1..\2] OF ')
|
||||
.each_line do |line|
|
||||
if line.start_with? 'proc'
|
||||
current_procedure = line[5...line.index('(')]
|
||||
|
||||
line = 'PROCEDURE ' + line[5..].gsub(',', ';')
|
||||
elsif line.start_with?('END;') && !current_procedure.nil?
|
||||
line = "END #{current_procedure};"
|
||||
current_proceure = nil
|
||||
elsif line.start_with?('end')
|
||||
line = 'END ' + line[4..]
|
||||
end
|
||||
target += line
|
||||
end
|
||||
|
||||
target_path = Pathname.new('boot/stage1/source') + source_path.basename.sub_ext('.mod')
|
||||
File.write target_path, target
|
||||
end
|
||||
FileList['source/*.def'].each do |file|
|
||||
cp file, File.join('boot/stage1/source', Pathname.new(file).basename)
|
||||
end
|
||||
end
|
||||
10
TODO
Normal file
10
TODO
Normal 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.
|
||||
88
elna.cabal
Normal file
88
elna.cabal
Normal 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
|
||||
326
lib/Language/Elna/Architecture/RiscV.hs
Normal file
326
lib/Language/Elna/Architecture/RiscV.hs
Normal 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
182
lib/Language/Elna/Backend/Allocator.hs
Normal 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
66
lib/Language/Elna/Backend/Intermediate.hs
Normal 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
37
lib/Language/Elna/Driver.hs
Normal 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
69
lib/Language/Elna/Driver/CommandLine.hs
Normal 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
210
lib/Language/Elna/Frontend/AST.hs
Normal 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
211
lib/Language/Elna/Frontend/NameAnalysis.hs
Normal 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
227
lib/Language/Elna/Frontend/Parser.hs
Normal 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
109
lib/Language/Elna/Frontend/SymbolTable.hs
Normal 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
208
lib/Language/Elna/Frontend/TypeAnalysis.hs
Normal 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
33
lib/Language/Elna/Frontend/Types.hs
Normal 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
312
lib/Language/Elna/Glue.hs
Normal 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
62
lib/Language/Elna/Location.hs
Normal 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
492
lib/Language/Elna/Object/Elf.hs
Normal 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
148
lib/Language/Elna/Object/ElfCoder.hs
Normal 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
48
lib/Language/Elna/Object/StringTable.hs
Normal 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
519
lib/Language/Elna/RiscV/CodeGenerator.hs
Normal 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
338
lib/Language/Elna/RiscV/ElfWriter.hs
Normal 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
|
||||
@ -1,7 +1,6 @@
|
||||
# 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/. -}
|
||||
# frozen_string_literal: true
|
||||
|
||||
require 'pathname'
|
||||
require 'uri'
|
||||
@ -9,13 +8,14 @@ require 'net/http'
|
||||
require 'rake/clean'
|
||||
require 'open3'
|
||||
require 'etc'
|
||||
require_relative 'shared'
|
||||
|
||||
GCC_VERSION = "15.1.0"
|
||||
BINUTILS_VERSION = '2.44'
|
||||
GLIBC_VERSION = '2.41'
|
||||
KERNEL_VERSION = '5.15.181'
|
||||
GCC_VERSION = "14.2.0"
|
||||
BINUTILS_VERSION = '2.43.1'
|
||||
GLIBC_VERSION = '2.40'
|
||||
KERNEL_VERSION = '5.15.166'
|
||||
|
||||
CLOBBER.include 'build'
|
||||
CLOBBER.include TMP
|
||||
|
||||
class BuildTarget
|
||||
attr_accessor(:build, :gcc, :target, :tmp)
|
||||
@ -35,6 +35,20 @@ class BuildTarget
|
||||
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)
|
||||
@ -63,7 +77,7 @@ def find_build_target(gcc_version, task)
|
||||
accumulator.gcc = line.split('=').last.strip
|
||||
end
|
||||
end
|
||||
result.tmp = Pathname.new('./build')
|
||||
result.tmp = TMP
|
||||
task.with_defaults target: 'riscv32-unknown-linux-gnu'
|
||||
result.target = task[:target]
|
||||
result
|
||||
@ -155,15 +169,11 @@ namespace :cross do
|
||||
options.sysroot.mkpath
|
||||
|
||||
sh 'contrib/download_prerequisites', chdir: source_directory.to_path
|
||||
configure_options = [
|
||||
configure_options = options.configuration + [
|
||||
"--prefix=#{options.rootfs.realpath}",
|
||||
"--with-sysroot=#{options.sysroot.realpath}",
|
||||
'--enable-languages=c,c++',
|
||||
'--disable-shared',
|
||||
'--with-arch=rv32imafdc',
|
||||
'--with-abi=ilp32d',
|
||||
'--with-tune=rocket',
|
||||
'--with-isa-spec=20191213',
|
||||
'--disable-bootstrap',
|
||||
'--disable-multilib',
|
||||
'--disable-libmudflap',
|
||||
@ -275,16 +285,12 @@ namespace :cross do
|
||||
rm_rf cwd
|
||||
cwd.mkpath
|
||||
|
||||
configure_options = [
|
||||
configure_options = options.configuration + [
|
||||
"--prefix=#{options.rootfs.realpath}",
|
||||
"--with-sysroot=#{options.sysroot.realpath}",
|
||||
'--enable-languages=c,c++,lto',
|
||||
'--enable-lto',
|
||||
'--enable-shared',
|
||||
'--with-arch=rv32imafdc',
|
||||
'--with-abi=ilp32d',
|
||||
'--with-tune=rocket',
|
||||
'--with-isa-spec=20191213',
|
||||
'--disable-bootstrap',
|
||||
'--disable-multilib',
|
||||
'--enable-checking=release',
|
||||
@ -309,15 +315,27 @@ namespace :cross do
|
||||
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: [
|
||||
task :cross, [:target] => [
|
||||
'cross:binutils',
|
||||
'cross:gcc1',
|
||||
'cross:headers',
|
||||
'cross:kernel',
|
||||
'cross:glibc',
|
||||
'cross:gcc2'
|
||||
'cross:gcc2',
|
||||
'cross:init'
|
||||
] do
|
||||
end
|
||||
|
||||
5
rakelib/shared.rb
Normal file
5
rakelib/shared.rb
Normal 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
100
rakelib/tester.rake
Normal 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
|
||||
@ -1,15 +0,0 @@
|
||||
DEFINITION MODULE CommandLineInterface;
|
||||
|
||||
FROM Common IMPORT ShortString;
|
||||
|
||||
TYPE
|
||||
CommandLine = RECORD
|
||||
input: ShortString;
|
||||
lex: BOOLEAN;
|
||||
parse: BOOLEAN
|
||||
END;
|
||||
PCommandLine = POINTER TO CommandLine;
|
||||
|
||||
PROCEDURE parse_command_line(): PCommandLine;
|
||||
|
||||
END CommandLineInterface.
|
||||
@ -1,75 +0,0 @@
|
||||
module;
|
||||
|
||||
from SYSTEM import ADR, TSIZE;
|
||||
|
||||
from Args import GetArg, Narg;
|
||||
from FIO import WriteString, WriteChar, WriteLine, StdErr;
|
||||
from Storage import ALLOCATE;
|
||||
from Strings import CompareStr, Length;
|
||||
from MemUtils import MemZero;
|
||||
|
||||
from Common import ShortString;
|
||||
|
||||
proc parse_command_line() -> PCommandLine;
|
||||
var
|
||||
parameter: ShortString;
|
||||
i: CARDINAL;
|
||||
result: PCommandLine;
|
||||
parsed: BOOLEAN;
|
||||
begin
|
||||
i := 1;
|
||||
ALLOCATE(result, TSIZE(CommandLine));
|
||||
result^.lex := false;
|
||||
result^.parse := false;
|
||||
MemZero(ADR(result^.input), 256);
|
||||
|
||||
while (i < Narg()) & (result <> nil) do
|
||||
parsed := GetArg(parameter, i);
|
||||
parsed := false;
|
||||
|
||||
if CompareStr(parameter, '--lex') = 0 then
|
||||
parsed := true;
|
||||
result^.lex := true
|
||||
end;
|
||||
if CompareStr(parameter, '--parse') = 0 then
|
||||
parsed := true;
|
||||
result^.parse := true
|
||||
end;
|
||||
if parameter[1] <> '-' then
|
||||
parsed := true;
|
||||
|
||||
if Length(result^.input) > 0 then
|
||||
WriteString(StdErr, 'Fatal error: only one source file can be compiled at once. First given "');
|
||||
WriteString(StdErr, result^.input);
|
||||
WriteString(StdErr, '", then "');
|
||||
WriteString(StdErr, parameter);
|
||||
WriteString(StdErr, '".');
|
||||
WriteLine(StdErr);
|
||||
result := nil
|
||||
end;
|
||||
if result <> nil then
|
||||
result^.input := parameter
|
||||
end
|
||||
end;
|
||||
if parsed = false then
|
||||
WriteString(StdErr, 'Fatal error: unknown command line options: ');
|
||||
|
||||
WriteString(StdErr, parameter);
|
||||
WriteChar(StdErr, '.');
|
||||
WriteLine(StdErr);
|
||||
|
||||
result := nil
|
||||
end;
|
||||
|
||||
i := i + 1
|
||||
end;
|
||||
if (result <> nil) & (Length(result^.input) = 0) then
|
||||
WriteString(StdErr, 'Fatal error: no input files.');
|
||||
WriteLine(StdErr);
|
||||
result := nil
|
||||
end;
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
end.
|
||||
@ -1,8 +0,0 @@
|
||||
DEFINITION MODULE Common;
|
||||
|
||||
TYPE
|
||||
ShortString = ARRAY[1..256] OF CHAR;
|
||||
Identifier = ARRAY[1..256] OF CHAR;
|
||||
PIdentifier = POINTER TO Identifier;
|
||||
|
||||
END Common.
|
||||
@ -1,3 +0,0 @@
|
||||
module;
|
||||
|
||||
end.
|
||||
@ -1,51 +0,0 @@
|
||||
program;
|
||||
|
||||
from FIO import Close, IsNoError, File, OpenToRead, StdErr, StdOut, WriteLine, WriteString;
|
||||
from SYSTEM import ADR;
|
||||
from M2RTS import HALT, ExitOnHalt;
|
||||
|
||||
from Lexer import Lexer, lexer_destroy, lexer_initialize;
|
||||
from Transpiler import transpile;
|
||||
from CommandLineInterface import PCommandLine, parse_command_line;
|
||||
|
||||
var
|
||||
command_line: PCommandLine;
|
||||
|
||||
proc compile_from_stream();
|
||||
var
|
||||
lexer: Lexer;
|
||||
source_input: File;
|
||||
begin
|
||||
source_input := OpenToRead(command_line^.input);
|
||||
|
||||
if IsNoError(source_input) = false then
|
||||
WriteString(StdErr, 'Fatal error: failed to read the input file "');
|
||||
WriteString(StdErr, command_line^.input);
|
||||
WriteString(StdErr, '".');
|
||||
WriteLine(StdErr);
|
||||
|
||||
ExitOnHalt(2)
|
||||
end;
|
||||
if IsNoError(source_input) then
|
||||
lexer_initialize(ADR(lexer), source_input);
|
||||
|
||||
transpile(ADR(lexer), StdOut, command_line^.input);
|
||||
|
||||
lexer_destroy(ADR(lexer));
|
||||
|
||||
Close(source_input)
|
||||
end
|
||||
end;
|
||||
|
||||
begin
|
||||
ExitOnHalt(0);
|
||||
command_line := parse_command_line();
|
||||
|
||||
if command_line <> nil then
|
||||
compile_from_stream()
|
||||
end;
|
||||
if command_line = nil then
|
||||
ExitOnHalt(1)
|
||||
end;
|
||||
HALT()
|
||||
end.
|
||||
@ -1,99 +0,0 @@
|
||||
DEFINITION MODULE Lexer;
|
||||
|
||||
FROM FIO IMPORT File;
|
||||
|
||||
FROM Common IMPORT Identifier;
|
||||
|
||||
TYPE
|
||||
PLexerBuffer = POINTER TO CHAR;
|
||||
Lexer = RECORD
|
||||
Input: File;
|
||||
Buffer: PLexerBuffer;
|
||||
Size: CARDINAL;
|
||||
Length: CARDINAL;
|
||||
Start: PLexerBuffer;
|
||||
Current: PLexerBuffer
|
||||
END;
|
||||
PLexer = POINTER TO Lexer;
|
||||
LexerKind = (
|
||||
lexerKindEof,
|
||||
lexerKindIdentifier,
|
||||
lexerKindIf,
|
||||
lexerKindThen,
|
||||
lexerKindElse,
|
||||
lexerKindElsif,
|
||||
lexerKindWhile,
|
||||
lexerKindDo,
|
||||
lexerKindProc,
|
||||
lexerKindBegin,
|
||||
lexerKindEnd,
|
||||
lexerKindImplementation,
|
||||
lexerKindConst,
|
||||
lexerKindVar,
|
||||
lexerKindCase,
|
||||
lexerKindOf,
|
||||
lexerKindType,
|
||||
lexerKindRecord,
|
||||
lexerKindUnion,
|
||||
lexerKindPipe,
|
||||
lexerKindTo,
|
||||
lexerKindBoolean,
|
||||
lexerKindNull,
|
||||
lexerKindAnd,
|
||||
lexerKindOr,
|
||||
lexerKindNot,
|
||||
lexerKindReturn,
|
||||
lexerKindDefinition,
|
||||
lexerKindRange,
|
||||
lexerKindLeftParen,
|
||||
lexerKindRightParen,
|
||||
lexerKindLeftSquare,
|
||||
lexerKindRightSquare,
|
||||
lexerKindGreaterEqual,
|
||||
lexerKindLessEqual,
|
||||
lexerKindGreaterThan,
|
||||
lexerKindLessThan,
|
||||
lexerKindNotEqual,
|
||||
lexerKindEqual,
|
||||
lexerKindSemicolon,
|
||||
lexerKindDot,
|
||||
lexerKindComma,
|
||||
lexerKindPlus,
|
||||
lexerKindMinus,
|
||||
lexerKindMultiplication,
|
||||
lexerKindDivision,
|
||||
lexerKindRemainder,
|
||||
lexerKindAssignment,
|
||||
lexerKindColon,
|
||||
lexerKindHat,
|
||||
lexerKindAt,
|
||||
lexerKindComment,
|
||||
lexerKindInteger,
|
||||
lexerKindWord,
|
||||
lexerKindCharacter,
|
||||
lexerKindString,
|
||||
lexerKindFrom,
|
||||
lexerKindPointer,
|
||||
lexerKindArray,
|
||||
lexerKindArrow,
|
||||
lexerKindProgram,
|
||||
lexerKindModule,
|
||||
lexerKindImport
|
||||
);
|
||||
LexerToken = RECORD
|
||||
CASE kind: LexerKind OF
|
||||
lexerKindBoolean: booleanKind: BOOLEAN |
|
||||
lexerKindIdentifier: identifierKind: Identifier |
|
||||
lexerKindInteger: integerKind: INTEGER
|
||||
END
|
||||
END;
|
||||
PLexerToken = POINTER TO LexerToken;
|
||||
|
||||
PROCEDURE lexer_initialize(ALexer: PLexer; Input: File);
|
||||
PROCEDURE lexer_destroy(ALexer: PLexer);
|
||||
(* Returns the last read token. *)
|
||||
PROCEDURE lexer_current(ALexer: PLexer): LexerToken;
|
||||
(* Read and return the next token. *)
|
||||
PROCEDURE lexer_lex(ALexer: PLexer): LexerToken;
|
||||
|
||||
END Lexer.
|
||||
@ -1,828 +0,0 @@
|
||||
module;
|
||||
|
||||
from FIO import ReadNBytes, StdErr;
|
||||
from SYSTEM import ADR, TSIZE;
|
||||
|
||||
from DynamicStrings import String, InitStringCharStar, KillString;
|
||||
from StringConvert import StringToInteger;
|
||||
from Storage import DEALLOCATE, ALLOCATE;
|
||||
from Strings import Length;
|
||||
from MemUtils import MemCopy, MemZero;
|
||||
from StrCase import Lower;
|
||||
|
||||
const
|
||||
CHUNK_SIZE = 65536;
|
||||
|
||||
type
|
||||
(*
|
||||
* Classification table assigns each possible character to a group (class). All
|
||||
* characters of the same group a handled equivalently.
|
||||
*
|
||||
* Classification:
|
||||
*)
|
||||
TransitionClass = (
|
||||
transitionClassInvalid,
|
||||
transitionClassDigit,
|
||||
transitionClassAlpha,
|
||||
transitionClassSpace,
|
||||
transitionClassColon,
|
||||
transitionClassEquals,
|
||||
transitionClassLeftParen,
|
||||
transitionClassRightParen,
|
||||
transitionClassAsterisk,
|
||||
transitionClassUnderscore,
|
||||
transitionClassSingle,
|
||||
transitionClassHex,
|
||||
transitionClassZero,
|
||||
transitionClassX,
|
||||
transitionClassEof,
|
||||
transitionClassDot,
|
||||
transitionClassMinus,
|
||||
transitionClassSingleQuote,
|
||||
transitionClassDoubleQuote,
|
||||
transitionClassGreater,
|
||||
transitionClassLess,
|
||||
transitionClassOther
|
||||
);
|
||||
TransitionState = (
|
||||
transitionStateStart,
|
||||
transitionStateColon,
|
||||
transitionStateIdentifier,
|
||||
transitionStateDecimal,
|
||||
transitionStateGreater,
|
||||
transitionStateMinus,
|
||||
transitionStateLeftParen,
|
||||
transitionStateLess,
|
||||
transitionStateDot,
|
||||
transitionStateComment,
|
||||
transitionStateClosingComment,
|
||||
transitionStateCharacter,
|
||||
transitionStateString,
|
||||
transitionStateLeadingZero,
|
||||
transitionStateDecimalSuffix,
|
||||
transitionStateEnd
|
||||
);
|
||||
TransitionAction = proc(PLexer, PLexerToken);
|
||||
Transition = record
|
||||
Action: TransitionAction;
|
||||
NextState: TransitionState
|
||||
end;
|
||||
TransitionClasses = [22]Transition;
|
||||
|
||||
var
|
||||
classification: [128]TransitionClass;
|
||||
transitions: [16]TransitionClasses;
|
||||
|
||||
proc initialize_classification();
|
||||
var
|
||||
i: CARDINAL;
|
||||
begin
|
||||
classification[1] := transitionClassEof; (* NUL *)
|
||||
classification[2] := transitionClassInvalid; (* SOH *)
|
||||
classification[3] := transitionClassInvalid; (* STX *)
|
||||
classification[4] := transitionClassInvalid; (* ETX *)
|
||||
classification[5] := transitionClassInvalid; (* EOT *)
|
||||
classification[6] := transitionClassInvalid; (* EMQ *)
|
||||
classification[7] := transitionClassInvalid; (* ACK *)
|
||||
classification[8] := transitionClassInvalid; (* BEL *)
|
||||
classification[9] := transitionClassInvalid; (* BS *)
|
||||
classification[10] := transitionClassSpace; (* HT *)
|
||||
classification[11] := transitionClassSpace; (* LF *)
|
||||
classification[12] := transitionClassInvalid; (* VT *)
|
||||
classification[13] := transitionClassInvalid; (* FF *)
|
||||
classification[14] := transitionClassSpace; (* CR *)
|
||||
classification[15] := transitionClassInvalid; (* SO *)
|
||||
classification[16] := transitionClassInvalid; (* SI *)
|
||||
classification[17] := transitionClassInvalid; (* DLE *)
|
||||
classification[18] := transitionClassInvalid; (* DC1 *)
|
||||
classification[19] := transitionClassInvalid; (* DC2 *)
|
||||
classification[20] := transitionClassInvalid; (* DC3 *)
|
||||
classification[21] := transitionClassInvalid; (* DC4 *)
|
||||
classification[22] := transitionClassInvalid; (* NAK *)
|
||||
classification[23] := transitionClassInvalid; (* SYN *)
|
||||
classification[24] := transitionClassInvalid; (* ETB *)
|
||||
classification[25] := transitionClassInvalid; (* CAN *)
|
||||
classification[26] := transitionClassInvalid; (* EM *)
|
||||
classification[27] := transitionClassInvalid; (* SUB *)
|
||||
classification[28] := transitionClassInvalid; (* ESC *)
|
||||
classification[29] := transitionClassInvalid; (* FS *)
|
||||
classification[30] := transitionClassInvalid; (* GS *)
|
||||
classification[31] := transitionClassInvalid; (* RS *)
|
||||
classification[32] := transitionClassInvalid; (* US *)
|
||||
classification[33] := transitionClassSpace; (* Space *)
|
||||
classification[34] := transitionClassSingle; (* ! *)
|
||||
classification[35] := transitionClassDoubleQuote; (* " *)
|
||||
classification[36] := transitionClassOther; (* # *)
|
||||
classification[37] := transitionClassOther; (* $ *)
|
||||
classification[38] := transitionClassSingle; (* % *)
|
||||
classification[39] := transitionClassSingle; (* & *)
|
||||
classification[40] := transitionClassSingleQuote; (* ' *)
|
||||
classification[41] := transitionClassLeftParen; (* ( *)
|
||||
classification[42] := transitionClassRightParen; (* ) *)
|
||||
classification[43] := transitionClassAsterisk; (* * *)
|
||||
classification[44] := transitionClassSingle; (* + *)
|
||||
classification[45] := transitionClassSingle; (* , *)
|
||||
classification[46] := transitionClassMinus; (* - *)
|
||||
classification[47] := transitionClassDot; (* . *)
|
||||
classification[48] := transitionClassSingle; (* / *)
|
||||
classification[49] := transitionClassZero; (* 0 *)
|
||||
classification[50] := transitionClassDigit; (* 1 *)
|
||||
classification[51] := transitionClassDigit; (* 2 *)
|
||||
classification[52] := transitionClassDigit; (* 3 *)
|
||||
classification[53] := transitionClassDigit; (* 4 *)
|
||||
classification[54] := transitionClassDigit; (* 5 *)
|
||||
classification[55] := transitionClassDigit; (* 6 *)
|
||||
classification[56] := transitionClassDigit; (* 7 *)
|
||||
classification[57] := transitionClassDigit; (* 8 *)
|
||||
classification[58] := transitionClassDigit; (* 9 *)
|
||||
classification[59] := transitionClassColon; (* : *)
|
||||
classification[60] := transitionClassSingle; (* ; *)
|
||||
classification[61] := transitionClassLess; (* < *)
|
||||
classification[62] := transitionClassEquals; (* = *)
|
||||
classification[63] := transitionClassGreater; (* > *)
|
||||
classification[64] := transitionClassOther; (* ? *)
|
||||
classification[65] := transitionClassSingle; (* @ *)
|
||||
classification[66] := transitionClassAlpha; (* A *)
|
||||
classification[67] := transitionClassAlpha; (* B *)
|
||||
classification[68] := transitionClassAlpha; (* C *)
|
||||
classification[69] := transitionClassAlpha; (* D *)
|
||||
classification[70] := transitionClassAlpha; (* E *)
|
||||
classification[71] := transitionClassAlpha; (* F *)
|
||||
classification[72] := transitionClassAlpha; (* G *)
|
||||
classification[73] := transitionClassAlpha; (* H *)
|
||||
classification[74] := transitionClassAlpha; (* I *)
|
||||
classification[75] := transitionClassAlpha; (* J *)
|
||||
classification[76] := transitionClassAlpha; (* K *)
|
||||
classification[77] := transitionClassAlpha; (* L *)
|
||||
classification[78] := transitionClassAlpha; (* M *)
|
||||
classification[79] := transitionClassAlpha; (* N *)
|
||||
classification[80] := transitionClassAlpha; (* O *)
|
||||
classification[81] := transitionClassAlpha; (* P *)
|
||||
classification[82] := transitionClassAlpha; (* Q *)
|
||||
classification[83] := transitionClassAlpha; (* R *)
|
||||
classification[84] := transitionClassAlpha; (* S *)
|
||||
classification[85] := transitionClassAlpha; (* T *)
|
||||
classification[86] := transitionClassAlpha; (* U *)
|
||||
classification[87] := transitionClassAlpha; (* V *)
|
||||
classification[88] := transitionClassAlpha; (* W *)
|
||||
classification[89] := transitionClassAlpha; (* X *)
|
||||
classification[90] := transitionClassAlpha; (* Y *)
|
||||
classification[91] := transitionClassAlpha; (* Z *)
|
||||
classification[92] := transitionClassSingle; (* [ *)
|
||||
classification[93] := transitionClassOther; (* \ *)
|
||||
classification[94] := transitionClassSingle; (* ] *)
|
||||
classification[95] := transitionClassSingle; (* ^ *)
|
||||
classification[96] := transitionClassUnderscore; (* _ *)
|
||||
classification[97] := transitionClassOther; (* ` *)
|
||||
classification[98] := transitionClassHex; (* a *)
|
||||
classification[99] := transitionClassHex; (* b *)
|
||||
classification[100] := transitionClassHex; (* c *)
|
||||
classification[101] := transitionClassHex; (* d *)
|
||||
classification[102] := transitionClassHex; (* e *)
|
||||
classification[103] := transitionClassHex; (* f *)
|
||||
classification[104] := transitionClassAlpha; (* g *)
|
||||
classification[105] := transitionClassAlpha; (* h *)
|
||||
classification[106] := transitionClassAlpha; (* i *)
|
||||
classification[107] := transitionClassAlpha; (* j *)
|
||||
classification[108] := transitionClassAlpha; (* k *)
|
||||
classification[109] := transitionClassAlpha; (* l *)
|
||||
classification[110] := transitionClassAlpha; (* m *)
|
||||
classification[111] := transitionClassAlpha; (* n *)
|
||||
classification[112] := transitionClassAlpha; (* o *)
|
||||
classification[113] := transitionClassAlpha; (* p *)
|
||||
classification[114] := transitionClassAlpha; (* q *)
|
||||
classification[115] := transitionClassAlpha; (* r *)
|
||||
classification[116] := transitionClassAlpha; (* s *)
|
||||
classification[117] := transitionClassAlpha; (* t *)
|
||||
classification[118] := transitionClassAlpha; (* u *)
|
||||
classification[119] := transitionClassAlpha; (* v *)
|
||||
classification[120] := transitionClassAlpha; (* w *)
|
||||
classification[121] := transitionClassX; (* x *)
|
||||
classification[122] := transitionClassAlpha; (* y *)
|
||||
classification[123] := transitionClassAlpha; (* z *)
|
||||
classification[124] := transitionClassOther; (* { *)
|
||||
classification[125] := transitionClassSingle; (* | *)
|
||||
classification[126] := transitionClassOther; (* } *)
|
||||
classification[127] := transitionClassSingle; (* ~ *)
|
||||
classification[128] := transitionClassInvalid; (* DEL *)
|
||||
|
||||
i := 129;
|
||||
while i <= 256 do
|
||||
classification[i] := transitionClassOther;
|
||||
i := i + 1
|
||||
end
|
||||
end;
|
||||
|
||||
proc compare_keyword(Keyword: ARRAY OF CHAR, TokenStart: PLexerBuffer, TokenEnd: PLexerBuffer) -> BOOLEAN;
|
||||
var
|
||||
result: BOOLEAN;
|
||||
index: CARDINAL;
|
||||
begin
|
||||
index := 0;
|
||||
result := true;
|
||||
|
||||
while (index < Length(Keyword)) & (TokenStart <> TokenEnd) & result DO
|
||||
result := (Keyword[index] = TokenStart^) or (Lower(Keyword[index]) = TokenStart^);
|
||||
INC(TokenStart);
|
||||
INC(index)
|
||||
end;
|
||||
result := (index = Length(Keyword)) & (TokenStart = TokenEnd) & result;
|
||||
return result
|
||||
end;
|
||||
|
||||
(* Reached the end of file. *)
|
||||
proc transition_action_eof(lexer: PLexer, token: PLexerToken);
|
||||
begin
|
||||
token^.kind := lexerKindEof
|
||||
end;
|
||||
|
||||
(* Add the character to the token currently read and advance to the next character. *)
|
||||
proc transition_action_accumulate(lexer: PLexer, token: PLexerToken);
|
||||
begin
|
||||
INC(lexer^.Current)
|
||||
end;
|
||||
|
||||
(* The current character is not a part of the token. Finish the token already
|
||||
* read. Don't advance to the next character. *)
|
||||
proc transition_action_finalize(lexer: PLexer, token: PLexerToken);
|
||||
begin
|
||||
if lexer^.Start^ = ':' then
|
||||
token^.kind := lexerKindColon
|
||||
end;
|
||||
if lexer^.Start^ = '>' then
|
||||
token^.kind := lexerKindGreaterThan
|
||||
end;
|
||||
if lexer^.Start^ = '<' then
|
||||
token^.kind := lexerKindLessThan
|
||||
end;
|
||||
if lexer^.Start^ = '(' then
|
||||
token^.kind := lexerKindLeftParen
|
||||
end;
|
||||
if lexer^.Start^ = '-' then
|
||||
token^.kind := lexerKindLeftParen
|
||||
end;
|
||||
if lexer^.Start^ = '.' then
|
||||
token^.kind := lexerKindDot
|
||||
end
|
||||
end;
|
||||
|
||||
(* An action for tokens containing multiple characters. *)
|
||||
proc transition_action_composite(lexer: PLexer, token: PLexerToken);
|
||||
begin
|
||||
if lexer^.Start^ = '<' then
|
||||
if lexer^.Current^ = '>' then
|
||||
token^.kind := lexerKindNotEqual
|
||||
end;
|
||||
if lexer^.Current^ = '=' then
|
||||
token^.kind := lexerKindLessEqual
|
||||
end
|
||||
end;
|
||||
if (lexer^.Start^ = '>') & (lexer^.Current^ = '=') then
|
||||
token^.kind := lexerKindGreaterEqual
|
||||
end;
|
||||
if (lexer^.Start^ = '.') & (lexer^.Current^ = '.') then
|
||||
token^.kind := lexerKindRange
|
||||
end;
|
||||
if (lexer^.Start^ = ':') & (lexer^.Current^ = '=') then
|
||||
token^.kind := lexerKindAssignment
|
||||
end;
|
||||
if (lexer^.Start^ = '-') & (lexer^.Current^ = '>') then
|
||||
token^.kind := lexerKindArrow
|
||||
end;
|
||||
INC(lexer^.Current)
|
||||
end;
|
||||
|
||||
(* Skip a space. *)
|
||||
proc transition_action_skip(lexer: PLexer, token: PLexerToken);
|
||||
begin
|
||||
INC(lexer^.Current);
|
||||
INC(lexer^.Start)
|
||||
end;
|
||||
|
||||
(* Delimited string action. *)
|
||||
proc transition_action_delimited(lexer: PLexer, token: PLexerToken);
|
||||
begin
|
||||
if lexer^.Start^ = '(' then
|
||||
token^.kind := lexerKindComment
|
||||
end;
|
||||
if lexer^.Start^ = '"' then
|
||||
token^.kind := lexerKindCharacter
|
||||
end;
|
||||
if lexer^.Start^ = "'" then
|
||||
token^.kind := lexerKindString
|
||||
end;
|
||||
INC(lexer^.Current)
|
||||
end;
|
||||
|
||||
(* Finalize keyword or identifier. *)
|
||||
proc transition_action_key_id(lexer: PLexer, token: PLexerToken);
|
||||
begin
|
||||
token^.kind := lexerKindIdentifier;
|
||||
|
||||
token^.identifierKind[1] := lexer^.Current - lexer^.Start;
|
||||
MemCopy(lexer^.Start, ORD(token^.identifierKind[1]), ADR(token^.identifierKind[2]));
|
||||
|
||||
if compare_keyword('PROGRAM', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindProgram
|
||||
end;
|
||||
if compare_keyword('IMPORT', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindImport
|
||||
end;
|
||||
if compare_keyword('CONST', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindConst
|
||||
end;
|
||||
if compare_keyword('VAR', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindVar
|
||||
end;
|
||||
if compare_keyword('IF', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindIf
|
||||
end;
|
||||
if compare_keyword('THEN', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindThen
|
||||
end;
|
||||
if compare_keyword('ELSIF', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindElsif
|
||||
end;
|
||||
if compare_keyword('ELSE', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindElse
|
||||
end;
|
||||
if compare_keyword('WHILE', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindWhile
|
||||
end;
|
||||
if compare_keyword('DO', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindDo
|
||||
end;
|
||||
if compare_keyword('proc', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindProc
|
||||
end;
|
||||
if compare_keyword('BEGIN', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindBegin
|
||||
end;
|
||||
if compare_keyword('END', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindEnd
|
||||
end;
|
||||
if compare_keyword('TYPE', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindType
|
||||
end;
|
||||
if compare_keyword('RECORD', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindRecord
|
||||
end;
|
||||
if compare_keyword('UNION', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindUnion
|
||||
end;
|
||||
if compare_keyword('NIL', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindNull
|
||||
end;
|
||||
if compare_keyword('AND', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindAnd
|
||||
end;
|
||||
if compare_keyword('OR', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindOr
|
||||
end;
|
||||
if compare_keyword('RETURN', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindReturn
|
||||
end;
|
||||
if compare_keyword('DEFINITION', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindDefinition
|
||||
end;
|
||||
if compare_keyword('TO', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindTo
|
||||
end;
|
||||
if compare_keyword('CASE', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindCase
|
||||
end;
|
||||
if compare_keyword('OF', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindOf
|
||||
end;
|
||||
if compare_keyword('FROM', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindFrom
|
||||
end;
|
||||
if compare_keyword('MODULE', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindModule
|
||||
end;
|
||||
if compare_keyword('IMPLEMENTATION', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindImplementation
|
||||
end;
|
||||
if compare_keyword('POINTER', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindPointer
|
||||
end;
|
||||
if compare_keyword('ARRAY', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindArray
|
||||
end;
|
||||
if compare_keyword('TRUE', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindBoolean;
|
||||
token^.booleanKind := true
|
||||
end;
|
||||
if compare_keyword('FALSE', lexer^.Start, lexer^.Current) then
|
||||
token^.kind := lexerKindBoolean;
|
||||
token^.booleanKind := false
|
||||
end
|
||||
end;
|
||||
|
||||
(* Action for tokens containing only one character. The character cannot be
|
||||
* followed by other characters forming a composite token. *)
|
||||
proc transition_action_single(lexer: PLexer, token: PLexerToken);
|
||||
begin
|
||||
if lexer^.Current^ = '&' then
|
||||
token^.kind := lexerKindAnd
|
||||
end;
|
||||
if lexer^.Current^ = ';' then
|
||||
token^.kind := lexerKindSemicolon
|
||||
end;
|
||||
if lexer^.Current^ = ',' then
|
||||
token^.kind := lexerKindComma
|
||||
end;
|
||||
if lexer^.Current^ = ',' then
|
||||
token^.kind := lexerKindComma
|
||||
end;
|
||||
if lexer^.Current^ = ')' then
|
||||
token^.kind := lexerKindRightParen
|
||||
end;
|
||||
if lexer^.Current^ = '[' then
|
||||
token^.kind := lexerKindLeftSquare
|
||||
end;
|
||||
if lexer^.Current^ = ']' then
|
||||
token^.kind := lexerKindRightSquare
|
||||
end;
|
||||
if lexer^.Current^ = '^' then
|
||||
token^.kind := lexerKindHat
|
||||
end;
|
||||
if lexer^.Current^ = '=' then
|
||||
token^.kind := lexerKindEqual
|
||||
end;
|
||||
if lexer^.Current^ = '+' then
|
||||
token^.kind := lexerKindPlus
|
||||
end;
|
||||
if lexer^.Current^ = '/' then
|
||||
token^.kind := lexerKindDivision
|
||||
end;
|
||||
if lexer^.Current^ = '%' then
|
||||
token^.kind := lexerKindRemainder
|
||||
end;
|
||||
if lexer^.Current^ = '@' then
|
||||
token^.kind := lexerKindAt
|
||||
end;
|
||||
if lexer^.Current^ = '|' then
|
||||
token^.kind := lexerKindPipe
|
||||
end;
|
||||
INC(lexer^.Current)
|
||||
end;
|
||||
|
||||
(* Handle an integer literal. *)
|
||||
proc transition_action_integer(lexer: PLexer, token: PLexerToken);
|
||||
var
|
||||
buffer: String;
|
||||
integer_length: CARDINAL;
|
||||
found: BOOLEAN;
|
||||
begin
|
||||
token^.kind := lexerKindInteger;
|
||||
|
||||
integer_length := lexer^.Current - lexer^.Start;
|
||||
MemZero(ADR(token^.identifierKind), TSIZE(Identifier));
|
||||
MemCopy(lexer^.Start, integer_length, ADR(token^.identifierKind[1]));
|
||||
|
||||
buffer := InitStringCharStar(ADR(token^.identifierKind[1]));
|
||||
token^.integerKind := StringToInteger(buffer, 10, found);
|
||||
buffer := KillString(buffer)
|
||||
end;
|
||||
|
||||
proc set_default_transition(CurrentState: TransitionState, DefaultAction: TransitionAction, NextState: TransitionState);
|
||||
var
|
||||
DefaultTransition: Transition;
|
||||
begin
|
||||
DefaultTransition.Action := DefaultAction;
|
||||
DefaultTransition.NextState := NextState;
|
||||
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassInvalid) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassDigit) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassAlpha) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassSpace) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassColon) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassEquals) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassLeftParen) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassRightParen) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassAsterisk) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassUnderscore) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassSingle) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassHex) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassZero) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassX) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassEof) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassDot) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassMinus) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassSingleQuote) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassDoubleQuote) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassGreater) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassLess) + 1] := DefaultTransition;
|
||||
transitions[ORD(CurrentState) + 1][ORD(transitionClassOther) + 1] := DefaultTransition
|
||||
end;
|
||||
|
||||
(*
|
||||
* The transition table describes transitions from one state to another, given
|
||||
* a symbol (character class).
|
||||
*
|
||||
* The table has m rows and n columns, where m is the amount of states and n is
|
||||
* the amount of classes. So given the current state and a classified character
|
||||
* the table can be used to look up the next state.
|
||||
*
|
||||
* Each cell is a word long.
|
||||
* - The least significant byte of the word is a row number (beginning with 0).
|
||||
* It specifies the target state. "ff" means that this is an end state and no
|
||||
* transition is possible.
|
||||
* - The next byte is the action that should be performed when transitioning.
|
||||
* For the meaning of actions see labels in the lex_next function, which
|
||||
* handles each action.
|
||||
*)
|
||||
proc initialize_transitions();
|
||||
begin
|
||||
(* Start state. *)
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassInvalid) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassInvalid) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassDigit) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassDigit) + 1].NextState := transitionStateDecimal;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassAlpha) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassAlpha) + 1].NextState := transitionStateIdentifier;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassSpace) + 1].Action := transition_action_skip;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassSpace) + 1].NextState := transitionStateStart;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassColon) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassColon) + 1].NextState := transitionStateColon;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassEquals) + 1].Action := transition_action_single;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassEquals) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassLeftParen) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassLeftParen) + 1].NextState := transitionStateLeftParen;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassRightParen) + 1].Action := transition_action_single;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassRightParen) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassAsterisk) + 1].Action := transition_action_single;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassAsterisk) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassUnderscore) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassUnderscore) + 1].NextState := transitionStateIdentifier;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassSingle) + 1].Action := transition_action_single;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassSingle) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassHex) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassHex) + 1].NextState := transitionStateIdentifier;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassZero) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassZero) + 1].NextState := transitionStateLeadingZero;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassX) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassX) + 1].NextState := transitionStateIdentifier;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassEof) + 1].Action := transition_action_eof;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassEof) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassDot) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassDot) + 1].NextState := transitionStateDot;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassMinus) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassMinus) + 1].NextState := transitionStateMinus;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassSingleQuote) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassSingleQuote) + 1].NextState := transitionStateCharacter;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassDoubleQuote) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassDoubleQuote) + 1].NextState := transitionStateString;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassGreater) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassGreater) + 1].NextState := transitionStateGreater;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassLess) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassLess) + 1].NextState := transitionStateLess;
|
||||
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassOther) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateStart) + 1][ORD(transitionClassOther) + 1].NextState := transitionStateEnd;
|
||||
|
||||
(* Colon state. *)
|
||||
set_default_transition(transitionStateColon, transition_action_finalize, transitionStateEnd);
|
||||
|
||||
transitions[ORD(transitionStateColon) + 1][ORD(transitionClassEquals) + 1].Action := transition_action_composite;
|
||||
transitions[ORD(transitionStateColon) + 1][ORD(transitionClassEquals) + 1].NextState := transitionStateEnd;
|
||||
|
||||
(* Identifier state. *)
|
||||
set_default_transition(transitionStateIdentifier, transition_action_key_id, transitionStateEnd);
|
||||
|
||||
transitions[ORD(transitionStateIdentifier) + 1][ORD(transitionClassDigit) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateIdentifier) + 1][ORD(transitionClassDigit) + 1].NextState := transitionStateIdentifier;
|
||||
|
||||
transitions[ORD(transitionStateIdentifier) + 1][ORD(transitionClassAlpha) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateIdentifier) + 1][ORD(transitionClassAlpha) + 1].NextState := transitionStateIdentifier;
|
||||
|
||||
transitions[ORD(transitionStateIdentifier) + 1][ORD(transitionClassUnderscore) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateIdentifier) + 1][ORD(transitionClassUnderscore) + 1].NextState := transitionStateIdentifier;
|
||||
|
||||
transitions[ORD(transitionStateIdentifier) + 1][ORD(transitionClassHex) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateIdentifier) + 1][ORD(transitionClassHex) + 1].NextState := transitionStateIdentifier;
|
||||
|
||||
transitions[ORD(transitionStateIdentifier) + 1][ORD(transitionClassZero) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateIdentifier) + 1][ORD(transitionClassZero) + 1].NextState := transitionStateIdentifier;
|
||||
|
||||
transitions[ORD(transitionStateIdentifier) + 1][ORD(transitionClassX) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateIdentifier) + 1][ORD(transitionClassX) + 1].NextState := transitionStateIdentifier;
|
||||
|
||||
(* Decimal state. *)
|
||||
set_default_transition(transitionStateDecimal, transition_action_integer, transitionStateEnd);
|
||||
|
||||
transitions[ORD(transitionStateDecimal) + 1][ORD(transitionClassDigit) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateDecimal) + 1][ORD(transitionClassDigit) + 1].NextState := transitionStateDecimal;
|
||||
|
||||
transitions[ORD(transitionStateDecimal) + 1][ORD(transitionClassAlpha) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateDecimal) + 1][ORD(transitionClassAlpha) + 1].NextState := transitionStateDecimalSuffix;
|
||||
|
||||
transitions[ORD(transitionStateDecimal) + 1][ORD(transitionClassUnderscore) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateDecimal) + 1][ORD(transitionClassUnderscore) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateDecimal) + 1][ORD(transitionClassHex) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateDecimal) + 1][ORD(transitionClassHex) + 1].NextState := transitionStateDecimalSuffix;
|
||||
|
||||
transitions[ORD(transitionStateDecimal) + 1][ORD(transitionClassZero) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateDecimal) + 1][ORD(transitionClassZero) + 1].NextState := transitionStateDecimal;
|
||||
|
||||
transitions[ORD(transitionStateDecimal) + 1][ORD(transitionClassX) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateDecimal) + 1][ORD(transitionClassX) + 1].NextState := transitionStateDecimalSuffix;
|
||||
|
||||
(* Greater state. *)
|
||||
set_default_transition(transitionStateGreater, transition_action_finalize, transitionStateEnd);
|
||||
|
||||
transitions[ORD(transitionStateGreater) + 1][ORD(transitionClassEquals) + 1].Action := transition_action_composite;
|
||||
transitions[ORD(transitionStateGreater) + 1][ORD(transitionClassEquals) + 1].NextState := transitionStateEnd;
|
||||
|
||||
(* Minus state. *)
|
||||
set_default_transition(transitionStateMinus, transition_action_finalize, transitionStateEnd);
|
||||
|
||||
transitions[ORD(transitionStateMinus) + 1][ORD(transitionClassGreater) + 1].Action := transition_action_composite;
|
||||
transitions[ORD(transitionStateMinus) + 1][ORD(transitionClassGreater) + 1].NextState := transitionStateEnd;
|
||||
|
||||
(* Left paren state. *)
|
||||
set_default_transition(transitionStateLeftParen, transition_action_finalize, transitionStateEnd);
|
||||
|
||||
transitions[ORD(transitionStateLeftParen) + 1][ORD(transitionClassAsterisk) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateLeftParen) + 1][ORD(transitionClassAsterisk) + 1].NextState := transitionStateComment;
|
||||
|
||||
(* Less state. *)
|
||||
set_default_transition(transitionStateLess, transition_action_finalize, transitionStateEnd);
|
||||
|
||||
transitions[ORD(transitionStateLess) + 1][ORD(transitionClassEquals) + 1].Action := transition_action_composite;
|
||||
transitions[ORD(transitionStateLess) + 1][ORD(transitionClassEquals) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateLess) + 1][ORD(transitionClassGreater) + 1].Action := transition_action_composite;
|
||||
transitions[ORD(transitionStateLess) + 1][ORD(transitionClassGreater) + 1].NextState := transitionStateEnd;
|
||||
|
||||
(* Hexadecimal after 0x. *)
|
||||
set_default_transition(transitionStateDot, transition_action_finalize, transitionStateEnd);
|
||||
|
||||
transitions[ORD(transitionStateDot) + 1][ORD(transitionClassDot) + 1].Action := transition_action_composite;
|
||||
transitions[ORD(transitionStateDot) + 1][ORD(transitionClassDot) + 1].NextState := transitionStateEnd;
|
||||
|
||||
(* Comment. *)
|
||||
set_default_transition(transitionStateComment, transition_action_accumulate, transitionStateComment);
|
||||
|
||||
transitions[ORD(transitionStateComment) + 1][ORD(transitionClassAsterisk) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateComment) + 1][ORD(transitionClassAsterisk) + 1].NextState := transitionStateClosingComment;
|
||||
|
||||
transitions[ORD(transitionStateComment) + 1][ORD(transitionClassEof) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateComment) + 1][ORD(transitionClassEof) + 1].NextState := transitionStateEnd;
|
||||
|
||||
(* Closing comment. *)
|
||||
set_default_transition(transitionStateClosingComment, transition_action_accumulate, transitionStateComment);
|
||||
|
||||
transitions[ORD(transitionStateClosingComment) + 1][ORD(transitionClassInvalid) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateClosingComment) + 1][ORD(transitionClassInvalid) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateClosingComment) + 1][ORD(transitionClassRightParen) + 1].Action := transition_action_delimited;
|
||||
transitions[ORD(transitionStateClosingComment) + 1][ORD(transitionClassRightParen) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateClosingComment) + 1][ORD(transitionClassAsterisk) + 1].Action := transition_action_accumulate;
|
||||
transitions[ORD(transitionStateClosingComment) + 1][ORD(transitionClassAsterisk) + 1].NextState := transitionStateClosingComment;
|
||||
|
||||
transitions[ORD(transitionStateClosingComment) + 1][ORD(transitionClassEof) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateClosingComment) + 1][ORD(transitionClassEof) + 1].NextState := transitionStateEnd;
|
||||
|
||||
(* Character. *)
|
||||
set_default_transition(transitionStateCharacter, transition_action_accumulate, transitionStateCharacter);
|
||||
|
||||
transitions[ORD(transitionStateCharacter) + 1][ORD(transitionClassInvalid) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateCharacter) + 1][ORD(transitionClassInvalid) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateCharacter) + 1][ORD(transitionClassEof) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateCharacter) + 1][ORD(transitionClassEof) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateCharacter) + 1][ORD(transitionClassSingleQuote) + 1].Action := transition_action_delimited;
|
||||
transitions[ORD(transitionStateCharacter) + 1][ORD(transitionClassSingleQuote) + 1].NextState := transitionStateEnd;
|
||||
|
||||
(* String. *)
|
||||
set_default_transition(transitionStateString, transition_action_accumulate, transitionStateString);
|
||||
|
||||
transitions[ORD(transitionStateString) + 1][ORD(transitionClassInvalid) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateString) + 1][ORD(transitionClassInvalid) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateString) + 1][ORD(transitionClassEof) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateString) + 1][ORD(transitionClassEof) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateString) + 1][ORD(transitionClassDoubleQuote) + 1].Action := transition_action_delimited;
|
||||
transitions[ORD(transitionStateString) + 1][ORD(transitionClassDoubleQuote) + 1].NextState := transitionStateEnd;
|
||||
|
||||
(* Leading zero. *)
|
||||
set_default_transition(transitionStateLeadingZero, transition_action_integer, transitionStateEnd);
|
||||
|
||||
transitions[ORD(transitionStateLeadingZero) + 1][ORD(transitionClassDigit) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateLeadingZero) + 1][ORD(transitionClassDigit) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateLeadingZero) + 1][ORD(transitionClassAlpha) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateLeadingZero) + 1][ORD(transitionClassAlpha) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateLeadingZero) + 1][ORD(transitionClassUnderscore) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateLeadingZero) + 1][ORD(transitionClassUnderscore) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateLeadingZero) + 1][ORD(transitionClassHex) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateLeadingZero) + 1][ORD(transitionClassHex) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateLeadingZero) + 1][ORD(transitionClassZero) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateLeadingZero) + 1][ORD(transitionClassZero) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateLeadingZero) + 1][ORD(transitionClassX) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateLeadingZero) + 1][ORD(transitionClassX) + 1].NextState := transitionStateEnd;
|
||||
|
||||
(* Digit with a character suffix. *)
|
||||
set_default_transition(transitionStateDecimalSuffix, transition_action_integer, transitionStateEnd);
|
||||
|
||||
transitions[ORD(transitionStateDecimalSuffix) + 1][ORD(transitionClassAlpha) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateDecimalSuffix) + 1][ORD(transitionClassAlpha) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateDecimalSuffix) + 1][ORD(transitionClassDigit) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateDecimalSuffix) + 1][ORD(transitionClassDigit) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateDecimalSuffix) + 1][ORD(transitionClassHex) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateDecimalSuffix) + 1][ORD(transitionClassHex) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateDecimalSuffix) + 1][ORD(transitionClassZero) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateDecimalSuffix) + 1][ORD(transitionClassZero) + 1].NextState := transitionStateEnd;
|
||||
|
||||
transitions[ORD(transitionStateDecimalSuffix) + 1][ORD(transitionClassX) + 1].Action := nil;
|
||||
transitions[ORD(transitionStateDecimalSuffix) + 1][ORD(transitionClassX) + 1].NextState := transitionStateEnd
|
||||
end;
|
||||
|
||||
proc lexer_initialize(lexer: PLexer, Input: File);
|
||||
begin
|
||||
lexer^.Input := Input;
|
||||
lexer^.Length := 0;
|
||||
|
||||
ALLOCATE(lexer^.Buffer, CHUNK_SIZE);
|
||||
MemZero(lexer^.Buffer, CHUNK_SIZE);
|
||||
lexer^.Size := CHUNK_SIZE
|
||||
end;
|
||||
|
||||
proc lexer_current(lexer: PLexer) -> LexerToken;
|
||||
var
|
||||
CurrentClass: TransitionClass;
|
||||
CurrentState: TransitionState;
|
||||
CurrentTransition: Transition;
|
||||
result: LexerToken;
|
||||
begin
|
||||
lexer^.Current := lexer^.Start;
|
||||
CurrentState := transitionStateStart;
|
||||
|
||||
while CurrentState <> transitionStateEnd DO
|
||||
CurrentClass := classification[ORD(lexer^.Current^) + 1];
|
||||
|
||||
CurrentTransition := transitions[ORD(CurrentState) + 1][ORD(CurrentClass) + 1];
|
||||
if CurrentTransition.Action <> nil then
|
||||
CurrentTransition.Action(lexer, ADR(result))
|
||||
end;
|
||||
CurrentState := CurrentTransition.NextState
|
||||
end;
|
||||
return result
|
||||
end;
|
||||
|
||||
proc lexer_lex(lexer: PLexer) -> LexerToken;
|
||||
var
|
||||
result: LexerToken;
|
||||
begin
|
||||
if lexer^.Length = 0 then
|
||||
lexer^.Length := ReadNBytes(lexer^.Input, CHUNK_SIZE, lexer^.Buffer);
|
||||
lexer^.Current := lexer^.Buffer
|
||||
end;
|
||||
lexer^.Start := lexer^.Current;
|
||||
|
||||
result := lexer_current(lexer);
|
||||
return result
|
||||
end;
|
||||
|
||||
proc lexer_destroy(lexer: PLexer);
|
||||
begin
|
||||
DEALLOCATE(lexer^.Buffer, lexer^.Size)
|
||||
end;
|
||||
|
||||
begin
|
||||
initialize_classification();
|
||||
initialize_transitions()
|
||||
end.
|
||||
@ -1,78 +0,0 @@
|
||||
DEFINITION MODULE Parser;
|
||||
|
||||
FROM Common IMPORT Identifier, PIdentifier;
|
||||
FROM Lexer IMPORT PLexer;
|
||||
|
||||
TYPE
|
||||
AstImportStatement = RECORD
|
||||
package: Identifier;
|
||||
symbols: PIdentifier
|
||||
END;
|
||||
PAstImportStatement = POINTER TO AstImportStatement;
|
||||
PPAstImportStatement = POINTER TO PAstImportStatement;
|
||||
|
||||
AstConstantDeclaration = RECORD
|
||||
constant_name: Identifier;
|
||||
constant_value: INTEGER
|
||||
END;
|
||||
PAstConstantDeclaration = POINTER TO AstConstantDeclaration;
|
||||
PPAstConstantDeclaration = POINTER TO PAstConstantDeclaration;
|
||||
|
||||
AstFieldDeclaration = RECORD
|
||||
field_name: Identifier;
|
||||
field_type: PAstTypeExpression
|
||||
END;
|
||||
PAstFieldDeclaration = POINTER TO AstFieldDeclaration;
|
||||
|
||||
AstTypeExpressionKind = (
|
||||
astTypeExpressionKindNamed,
|
||||
astTypeExpressionKindRecord,
|
||||
astTypeExpressionKindEnumeration,
|
||||
astTypeExpressionKindArray,
|
||||
astTypeExpressionKindPointer,
|
||||
astTypeExpressionKindProcedure
|
||||
);
|
||||
AstTypeExpression = RECORD
|
||||
CASE kind: AstTypeExpressionKind OF
|
||||
astTypeExpressionKindNamed: name: Identifier |
|
||||
astTypeExpressionKindEnumeration: cases: PIdentifier |
|
||||
astTypeExpressionKindPointer: target: PAstTypeExpression |
|
||||
astTypeExpressionKindRecord: fields: PAstFieldDeclaration |
|
||||
astTypeExpressionKindArray:
|
||||
base: PAstTypeExpression;
|
||||
length: CARDINAL |
|
||||
astTypeExpressionKindProcedure: parameters: PPAstTypeExpression
|
||||
END
|
||||
END;
|
||||
PAstTypeExpression = POINTER TO AstTypeExpression;
|
||||
PPAstTypeExpression = POINTER TO PAstTypeExpression;
|
||||
|
||||
AstTypeDeclaration = RECORD
|
||||
identifier: Identifier;
|
||||
type_expression: PAstTypeExpression
|
||||
END;
|
||||
PAstTypeDeclaration = POINTER TO AstTypeDeclaration;
|
||||
PPAstTypeDeclaration = POINTER TO PAstTypeDeclaration;
|
||||
|
||||
AstVariableDeclaration = RECORD
|
||||
variable_name: Identifier;
|
||||
variable_type: PAstTypeExpression
|
||||
END;
|
||||
PAstVariableDeclaration = POINTER TO AstVariableDeclaration;
|
||||
PPAstVariableDeclaration = POINTER TO PAstVariableDeclaration;
|
||||
|
||||
AstModule = RECORD
|
||||
imports: PPAstImportStatement;
|
||||
constants: PPAstConstantDeclaration;
|
||||
types: PPAstTypeDeclaration;
|
||||
variables: PPAstVariableDeclaration
|
||||
END;
|
||||
PAstModule = POINTER TO AstModule;
|
||||
|
||||
PROCEDURE parse_type_expression(lexer: PLexer): PAstTypeExpression;
|
||||
PROCEDURE parse_type_part(lexer: PLexer): PPAstTypeDeclaration;
|
||||
PROCEDURE parse_variable_part(lexer: PLexer): PPAstVariableDeclaration;
|
||||
PROCEDURE parse_constant_part(lexer: PLexer): PPAstConstantDeclaration;
|
||||
PROCEDURE parse_import_part(lexer: PLexer): PPAstImportStatement;
|
||||
|
||||
END Parser.
|
||||
@ -1,466 +0,0 @@
|
||||
module;
|
||||
|
||||
from SYSTEM import TSIZE;
|
||||
|
||||
from MemUtils import MemZero;
|
||||
from Storage import ALLOCATE, REALLOCATE;
|
||||
|
||||
from Lexer import LexerKind, LexerToken, lexer_current, lexer_lex;
|
||||
|
||||
(* Calls lexer_lex() but skips the comments. *)
|
||||
proc transpiler_lex(lexer: PLexer) -> LexerToken;
|
||||
var
|
||||
result: LexerToken;
|
||||
begin
|
||||
result := lexer_lex(lexer);
|
||||
|
||||
while result.kind = lexerKindComment do
|
||||
result := lexer_lex(lexer)
|
||||
end;
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_type_fields(lexer: PLexer) -> PAstFieldDeclaration;
|
||||
var
|
||||
token: LexerToken;
|
||||
field_declarations: PAstFieldDeclaration;
|
||||
field_count: CARDINAL;
|
||||
current_field: PAstFieldDeclaration;
|
||||
begin
|
||||
ALLOCATE(field_declarations, TSIZE(AstFieldDeclaration));
|
||||
token := transpiler_lex(lexer);
|
||||
field_count := 0;
|
||||
|
||||
while token.kind <> lexerKindEnd do
|
||||
INC(field_count);
|
||||
REALLOCATE(field_declarations, TSIZE(AstFieldDeclaration) * (field_count + 1));
|
||||
current_field := field_declarations;
|
||||
INC(current_field , TSIZE(AstFieldDeclaration) * (field_count - 1));
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
current_field^.field_name := token.identifierKind;
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
current_field^.field_type := parse_type_expression(lexer);
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
if token.kind = lexerKindSemicolon then
|
||||
token := transpiler_lex(lexer)
|
||||
end
|
||||
end;
|
||||
INC(current_field, TSIZE(AstFieldDeclaration));
|
||||
MemZero(current_field, TSIZE(AstFieldDeclaration));
|
||||
|
||||
return field_declarations
|
||||
end;
|
||||
|
||||
proc parse_record_type(lexer: PLexer) -> PAstTypeExpression;
|
||||
var
|
||||
result: PAstTypeExpression;
|
||||
begin
|
||||
ALLOCATE(result, TSIZE(AstTypeExpression));
|
||||
result^.kind := astTypeExpressionKindRecord;
|
||||
result^.fields := parse_type_fields(lexer);
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_pointer_type(lexer: PLexer) -> PAstTypeExpression;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: PAstTypeExpression;
|
||||
begin
|
||||
ALLOCATE(result, TSIZE(AstTypeExpression));
|
||||
result^.kind := astTypeExpressionKindPointer;
|
||||
|
||||
token := lexer_current(lexer);
|
||||
|
||||
if token.kind = lexerKindPointer then
|
||||
token := transpiler_lex(lexer)
|
||||
end;
|
||||
token := lexer_current(lexer);
|
||||
result^.target := parse_type_expression(lexer);
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_array_type(lexer: PLexer) -> PAstTypeExpression;
|
||||
var
|
||||
token: LexerToken;
|
||||
buffer: [20]CHAR;
|
||||
result: PAstTypeExpression;
|
||||
begin
|
||||
ALLOCATE(result, TSIZE(AstTypeExpression));
|
||||
result^.kind := astTypeExpressionKindArray;
|
||||
result^.length := 0;
|
||||
|
||||
token := lexer_current(lexer);
|
||||
|
||||
if token.kind = lexerKindArray then
|
||||
token := transpiler_lex(lexer)
|
||||
end;
|
||||
if token.kind <> lexerKindOf then
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
result^.length := token.integerKind;
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
end;
|
||||
token := transpiler_lex(lexer);
|
||||
result^.base := parse_type_expression(lexer);
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_enumeration_type(lexer: PLexer) -> PAstTypeExpression;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: PAstTypeExpression;
|
||||
current_case: PIdentifier;
|
||||
case_count: CARDINAL;
|
||||
begin
|
||||
ALLOCATE(result, TSIZE(AstTypeExpression));
|
||||
result^.kind := astTypeExpressionKindEnumeration;
|
||||
|
||||
case_count := 1;
|
||||
ALLOCATE(result^.cases, TSIZE(Identifier) * 2);
|
||||
token := transpiler_lex(lexer);
|
||||
current_case := result^.cases;
|
||||
current_case^ := token.identifierKind;
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
while token.kind = lexerKindComma do
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
INC(case_count);
|
||||
REALLOCATE(result^.cases, TSIZE(Identifier) * (case_count + 1));
|
||||
current_case := result^.cases;
|
||||
INC(current_case, TSIZE(Identifier) * (case_count - 1));
|
||||
current_case^ := token.identifierKind;
|
||||
|
||||
token := transpiler_lex(lexer)
|
||||
end;
|
||||
INC(current_case, TSIZE(Identifier));
|
||||
MemZero(current_case, TSIZE(Identifier));
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_named_type(lexer: PLexer) -> PAstTypeExpression;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: PAstTypeExpression;
|
||||
written_bytes: CARDINAL;
|
||||
begin
|
||||
token := lexer_current(lexer);
|
||||
ALLOCATE(result, TSIZE(AstTypeExpression));
|
||||
|
||||
result^.kind := astTypeExpressionKindNamed;
|
||||
result^.name := token.identifierKind;
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_procedure_type(lexer: PLexer) -> PAstTypeExpression;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: PAstTypeExpression;
|
||||
current_parameter: PPAstTypeExpression;
|
||||
parameter_count: CARDINAL;
|
||||
begin
|
||||
parameter_count := 0;
|
||||
ALLOCATE(result, TSIZE(AstTypeExpression));
|
||||
result^.kind := astTypeExpressionKindProcedure;
|
||||
|
||||
ALLOCATE(result^.parameters, 1);
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
while token.kind <> lexerKindRightParen do
|
||||
INC(parameter_count);
|
||||
REALLOCATE(result^.parameters, TSIZE(PAstTypeExpression) * (parameter_count + 1));
|
||||
current_parameter := result^.parameters;
|
||||
INC(current_parameter, TSIZE(PAstTypeExpression) * (parameter_count - 1));
|
||||
|
||||
current_parameter^ := parse_type_expression(lexer);
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
if token.kind = lexerKindComma then
|
||||
token := transpiler_lex(lexer)
|
||||
end
|
||||
end;
|
||||
current_parameter := result^.parameters;
|
||||
INC(current_parameter, TSIZE(PAstTypeExpression) * parameter_count);
|
||||
current_parameter^ := nil;
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_type_expression(lexer: PLexer) -> PAstTypeExpression;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: PAstTypeExpression;
|
||||
begin
|
||||
result := nil;
|
||||
token := lexer_current(lexer);
|
||||
|
||||
if token.kind = lexerKindRecord then
|
||||
result := parse_record_type(lexer)
|
||||
end;
|
||||
if token.kind = lexerKindLeftParen then
|
||||
result := parse_enumeration_type(lexer)
|
||||
end;
|
||||
if (token.kind = lexerKindArray) or (token.kind = lexerKindLeftSquare) then
|
||||
result := parse_array_type(lexer)
|
||||
end;
|
||||
if token.kind = lexerKindHat then
|
||||
result := parse_pointer_type(lexer)
|
||||
end;
|
||||
if token.kind = lexerKindProc then
|
||||
result := parse_procedure_type(lexer)
|
||||
end;
|
||||
if token.kind = lexerKindIdentifier then
|
||||
result := parse_named_type(lexer)
|
||||
end;
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_type_declaration(lexer: PLexer) -> PAstTypeDeclaration;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: PAstTypeDeclaration;
|
||||
begin
|
||||
token := lexer_current(lexer);
|
||||
|
||||
ALLOCATE(result, TSIZE(AstTypeDeclaration));
|
||||
result^.identifier := token.identifierKind;
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
result^.type_expression := parse_type_expression(lexer);
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_type_part(lexer: PLexer) -> PPAstTypeDeclaration;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: PPAstTypeDeclaration;
|
||||
current_declaration: PPAstTypeDeclaration;
|
||||
declaration_count: CARDINAL;
|
||||
begin
|
||||
token := lexer_current(lexer);
|
||||
|
||||
ALLOCATE(result, TSIZE(PAstTypeDeclaration));
|
||||
current_declaration := result;
|
||||
declaration_count := 0;
|
||||
|
||||
if token.kind = lexerKindType then
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
while token.kind = lexerKindIdentifier do
|
||||
INC(declaration_count);
|
||||
|
||||
REALLOCATE(result, TSIZE(PAstTypeDeclaration) * (declaration_count + 1));
|
||||
current_declaration := result;
|
||||
INC(current_declaration, TSIZE(PAstTypeDeclaration) * (declaration_count - 1));
|
||||
|
||||
current_declaration^ := parse_type_declaration(lexer);
|
||||
token := transpiler_lex(lexer)
|
||||
end
|
||||
end;
|
||||
if declaration_count <> 0 then
|
||||
INC(current_declaration, TSIZE(PAstTypeDeclaration))
|
||||
end;
|
||||
current_declaration^ := nil;
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_variable_declaration(lexer: PLexer) -> PAstVariableDeclaration;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: PAstVariableDeclaration;
|
||||
begin
|
||||
ALLOCATE(result, TSIZE(AstVariableDeclaration));
|
||||
|
||||
token := lexer_current(lexer);
|
||||
result^.variable_name := token.identifierKind;
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
result^.variable_type := parse_type_expression(lexer);
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_variable_part(lexer: PLexer) -> PPAstVariableDeclaration;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: PPAstVariableDeclaration;
|
||||
current_declaration: PPAstVariableDeclaration;
|
||||
declaration_count: CARDINAL;
|
||||
begin
|
||||
token := lexer_current(lexer);
|
||||
|
||||
ALLOCATE(result, TSIZE(PAstVariableDeclaration));
|
||||
current_declaration := result;
|
||||
declaration_count := 0;
|
||||
|
||||
if token.kind = lexerKindVar then
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
while token.kind = lexerKindIdentifier do
|
||||
INC(declaration_count);
|
||||
|
||||
REALLOCATE(result, TSIZE(PAstVariableDeclaration) * (declaration_count + 1));
|
||||
current_declaration := result;
|
||||
INC(current_declaration, TSIZE(PAstVariableDeclaration) * (declaration_count - 1));
|
||||
|
||||
current_declaration^ := parse_variable_declaration(lexer);
|
||||
token := transpiler_lex(lexer)
|
||||
end
|
||||
end;
|
||||
if declaration_count <> 0 then
|
||||
INC(current_declaration, TSIZE(PAstVariableDeclaration))
|
||||
end;
|
||||
current_declaration^ := nil;
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_constant_declaration(lexer: PLexer) -> PAstConstantDeclaration;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: PAstConstantDeclaration;
|
||||
begin
|
||||
ALLOCATE(result, TSIZE(AstConstantDeclaration));
|
||||
|
||||
token := lexer_current(lexer);
|
||||
result^.constant_name := token.identifierKind;
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
result^.constant_value := token.integerKind;
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_constant_part(lexer: PLexer) -> PPAstConstantDeclaration;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: PPAstConstantDeclaration;
|
||||
current_declaration: PPAstConstantDeclaration;
|
||||
declaration_count: CARDINAL;
|
||||
begin
|
||||
token := lexer_current(lexer);
|
||||
|
||||
ALLOCATE(result, TSIZE(PAstConstantDeclaration));
|
||||
current_declaration := result;
|
||||
declaration_count := 0;
|
||||
|
||||
if token.kind = lexerKindConst then
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
while token.kind = lexerKindIdentifier do
|
||||
INC(declaration_count);
|
||||
|
||||
REALLOCATE(result, TSIZE(PAstConstantDeclaration) * (declaration_count + 1));
|
||||
current_declaration := result;
|
||||
INC(current_declaration, TSIZE(PAstConstantDeclaration) * (declaration_count - 1));
|
||||
|
||||
current_declaration^ := parse_constant_declaration(lexer);
|
||||
token := transpiler_lex(lexer)
|
||||
end
|
||||
end;
|
||||
if declaration_count <> 0 then
|
||||
INC(current_declaration, TSIZE(PAstConstantDeclaration))
|
||||
end;
|
||||
current_declaration^ := nil;
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_import_statement(lexer: PLexer) -> PAstImportStatement;
|
||||
var
|
||||
result: PAstImportStatement;
|
||||
token: LexerToken;
|
||||
symbol_count: CARDINAL;
|
||||
current_symbol: PIdentifier;
|
||||
begin
|
||||
ALLOCATE(result, TSIZE(AstImportStatement));
|
||||
symbol_count := 1;
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
result^.package := token.identifierKind;
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
ALLOCATE(result^.symbols, TSIZE(Identifier) * 2);
|
||||
|
||||
current_symbol := result^.symbols;
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
current_symbol^ := token.identifierKind;
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
while token.kind <> lexerKindSemicolon do
|
||||
token := transpiler_lex(lexer);
|
||||
INC(symbol_count);
|
||||
|
||||
REALLOCATE(result^.symbols, TSIZE(Identifier) * (symbol_count + 1));
|
||||
current_symbol := result^.symbols;
|
||||
INC(current_symbol, TSIZE(Identifier) * (symbol_count - 1));
|
||||
|
||||
current_symbol^ := token.identifierKind;
|
||||
token := transpiler_lex(lexer)
|
||||
end;
|
||||
INC(current_symbol, TSIZE(Identifier));
|
||||
MemZero(current_symbol, TSIZE(Identifier));
|
||||
|
||||
token := transpiler_lex(lexer);
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc parse_import_part(lexer: PLexer) -> PPAstImportStatement;
|
||||
var
|
||||
token: LexerToken;
|
||||
import_statement: PPAstImportStatement;
|
||||
result: PPAstImportStatement;
|
||||
import_count: CARDINAL;
|
||||
begin
|
||||
token := lexer_current(lexer);
|
||||
ALLOCATE(result, TSIZE(PAstImportStatement));
|
||||
import_statement := result;
|
||||
import_count := 0;
|
||||
|
||||
while token.kind = lexerKindFrom do
|
||||
INC(import_count);
|
||||
|
||||
REALLOCATE(result, TSIZE(PAstImportStatement) * (import_count + 1));
|
||||
import_statement := result;
|
||||
INC(import_statement, TSIZE(PAstImportStatement) * (import_count - 1));
|
||||
|
||||
import_statement^ := parse_import_statement(lexer);
|
||||
token := lexer_current(lexer)
|
||||
end;
|
||||
if import_count > 0 then
|
||||
INC(import_statement, TSIZE(PAstImportStatement))
|
||||
end;
|
||||
import_statement^ := nil;
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
end.
|
||||
@ -1,18 +0,0 @@
|
||||
DEFINITION MODULE Transpiler;
|
||||
|
||||
FROM FIO IMPORT File;
|
||||
|
||||
FROM Common IMPORT ShortString;
|
||||
FROM Lexer IMPORT PLexer, Lexer;
|
||||
|
||||
TYPE
|
||||
TranspilerContext = RECORD
|
||||
input_name: ShortString;
|
||||
output: File;
|
||||
lexer: PLexer
|
||||
END;
|
||||
PTranspilerContext = POINTER TO TranspilerContext;
|
||||
|
||||
PROCEDURE transpile(lexer: PLexer; output: File; input_name: ShortString);
|
||||
|
||||
END Transpiler.
|
||||
@ -1,680 +0,0 @@
|
||||
module;
|
||||
|
||||
from FIO import WriteNBytes, WriteLine, WriteChar, WriteString;
|
||||
from SYSTEM import ADR, ADDRESS, TSIZE;
|
||||
|
||||
from NumberIO import IntToStr;
|
||||
from Storage import ALLOCATE, REALLOCATE;
|
||||
from MemUtils import MemCopy, MemZero;
|
||||
|
||||
from Common import Identifier, PIdentifier, ShortString;
|
||||
from Lexer import Lexer, LexerToken, lexer_current, lexer_lex, LexerKind;
|
||||
from Parser import AstModule, PAstModule, AstTypeExpressionKind,
|
||||
PAstConstantDeclaration, PPAstConstantDeclaration,
|
||||
AstTypeDeclaration, PAstTypeDeclaration, PPAstTypeDeclaration,
|
||||
PAstVariableDeclaration, PPAstVariableDeclaration, PAstImportStatement, PPAstImportStatement,
|
||||
PAstTypeExpression, PPAstTypeExpression, AstFieldDeclaration, PAstFieldDeclaration,
|
||||
parse_type_expression, parse_variable_part, parse_type_part, parse_constant_part, parse_import_part;
|
||||
|
||||
(* Calls lexer_lex() but skips the comments. *)
|
||||
proc transpiler_lex(lexer: PLexer) -> LexerToken;
|
||||
var
|
||||
result: LexerToken;
|
||||
begin
|
||||
result := lexer_lex(lexer);
|
||||
|
||||
while result.kind = lexerKindComment do
|
||||
result := lexer_lex(lexer)
|
||||
end;
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
(* Write a semicolon followed by a newline. *)
|
||||
proc write_semicolon(output: File);
|
||||
begin
|
||||
WriteChar(output, ';');
|
||||
WriteLine(output)
|
||||
end;
|
||||
|
||||
proc write_current(lexer: PLexer, output: File);
|
||||
var
|
||||
written_bytes: CARDINAL;
|
||||
begin
|
||||
written_bytes := WriteNBytes(output, ADDRESS(lexer^.Current - lexer^.Start), lexer^.Start)
|
||||
end;
|
||||
|
||||
proc transpile_import_statement(context: PTranspilerContext, import_statement: PAstImportStatement);
|
||||
var
|
||||
token: LexerToken;
|
||||
written_bytes: CARDINAL;
|
||||
current_symbol: PIdentifier;
|
||||
begin
|
||||
WriteString(context^.output, 'FROM ');
|
||||
written_bytes := WriteNBytes(context^.output, ORD(import_statement^.package[1]), ADR(import_statement^.package[2]));
|
||||
|
||||
WriteString(context^.output, ' IMPORT ');
|
||||
|
||||
current_symbol := import_statement^.symbols;
|
||||
written_bytes := WriteNBytes(context^.output, ORD(current_symbol^[1]), ADR(current_symbol^[2]));
|
||||
INC(current_symbol, TSIZE(Identifier));
|
||||
|
||||
while ORD(current_symbol^[1]) <> 0 do
|
||||
WriteString(context^.output, ', ');
|
||||
written_bytes := WriteNBytes(context^.output, ORD(current_symbol^[1]), ADR(current_symbol^[2]));
|
||||
INC(current_symbol, TSIZE(Identifier))
|
||||
end;
|
||||
write_semicolon(context^.output)
|
||||
end;
|
||||
|
||||
proc transpile_import_part(context: PTranspilerContext, imports: PPAstImportStatement);
|
||||
var
|
||||
import_statement: PAstImportStatement;
|
||||
begin
|
||||
while imports^ <> nil do
|
||||
transpile_import_statement(context, imports^);
|
||||
INC(imports, TSIZE(PAstImportStatement))
|
||||
end;
|
||||
WriteLine(context^.output)
|
||||
end;
|
||||
|
||||
proc transpile_constant_declaration(context: PTranspilerContext, declaration: PAstConstantDeclaration);
|
||||
var
|
||||
buffer: [20]CHAR;
|
||||
written_bytes: CARDINAL;
|
||||
begin
|
||||
WriteString(context^.output, ' ');
|
||||
written_bytes := WriteNBytes(context^.output, ORD(declaration^.constant_name[1]), ADR(declaration^.constant_name[2]));
|
||||
|
||||
WriteString(context^.output, ' = ');
|
||||
|
||||
IntToStr(declaration^.constant_value, 0, buffer);
|
||||
WriteString(context^.output, buffer);
|
||||
|
||||
write_semicolon(context^.output)
|
||||
end;
|
||||
|
||||
proc transpile_constant_part(context: PTranspilerContext, declarations: PPAstConstantDeclaration);
|
||||
var
|
||||
current_declaration: PPAstConstantDeclaration;
|
||||
begin
|
||||
if declarations^ <> nil then
|
||||
WriteString(context^.output, 'CONST');
|
||||
WriteLine(context^.output);
|
||||
|
||||
current_declaration := declarations;
|
||||
while current_declaration^ <> nil do
|
||||
transpile_constant_declaration(context, current_declaration^);
|
||||
|
||||
INC(current_declaration, TSIZE(PAstConstantDeclaration))
|
||||
end;
|
||||
WriteLine(context^.output)
|
||||
end
|
||||
end;
|
||||
|
||||
proc transpile_module(context: PTranspilerContext) -> PAstModule;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: PAstModule;
|
||||
begin
|
||||
ALLOCATE(result, TSIZE(AstModule));
|
||||
token := transpiler_lex(context^.lexer);
|
||||
|
||||
if token.kind = lexerKindModule then
|
||||
WriteString(context^.output, 'IMPLEMENTATION ')
|
||||
end;
|
||||
WriteString(context^.output, 'MODULE ');
|
||||
|
||||
(* Write the module name and end the line with a semicolon and newline. *)
|
||||
transpile_module_name(context);
|
||||
|
||||
token := transpiler_lex(context^.lexer);
|
||||
write_semicolon(context^.output);
|
||||
WriteLine(context^.output);
|
||||
|
||||
(* Write the module body. *)
|
||||
token := transpiler_lex(context^.lexer);
|
||||
|
||||
result^.imports := parse_import_part(context^.lexer);
|
||||
transpile_import_part(context, result^.imports);
|
||||
|
||||
result^.constants := parse_constant_part(context^.lexer);
|
||||
transpile_constant_part(context, result^.constants);
|
||||
result^.types := parse_type_part(context^.lexer);
|
||||
transpile_type_part(context, result^.types);
|
||||
|
||||
result^.variables := parse_variable_part(context^.lexer);
|
||||
transpile_variable_part(context, result^.variables);
|
||||
|
||||
transpile_procedure_part(context);
|
||||
transpile_statement_part(context);
|
||||
|
||||
WriteString(context^.output, 'END ');
|
||||
transpile_module_name(context);
|
||||
|
||||
token := transpiler_lex(context^.lexer);
|
||||
WriteChar(context^.output, '.');
|
||||
|
||||
token := transpiler_lex(context^.lexer);
|
||||
WriteLine(context^.output);
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc transpile_type_fields(context: PTranspilerContext, fields: PAstFieldDeclaration);
|
||||
var
|
||||
written_bytes: CARDINAL;
|
||||
current_field: PAstFieldDeclaration;
|
||||
begin
|
||||
current_field := fields;
|
||||
|
||||
while ORD(current_field^.field_name[1]) <> 0 do
|
||||
WriteString(context^.output, ' ');
|
||||
written_bytes := WriteNBytes(context^.output, ORD(current_field^.field_name[1]), ADR(current_field^.field_name[2]));
|
||||
|
||||
WriteString(context^.output, ': ');
|
||||
transpile_type_expression(context, current_field^.field_type);
|
||||
|
||||
INC(current_field , TSIZE(AstFieldDeclaration));
|
||||
|
||||
if ORD(current_field^.field_name[1]) <> 0 then
|
||||
WriteChar(context^.output, ';')
|
||||
end;
|
||||
WriteLine(context^.output)
|
||||
end
|
||||
end;
|
||||
|
||||
proc transpile_record_type(context: PTranspilerContext, type_expression: PAstTypeExpression);
|
||||
begin
|
||||
WriteString(context^.output, 'RECORD');
|
||||
WriteLine(context^.output);
|
||||
transpile_type_fields(context, type_expression^.fields);
|
||||
WriteString(context^.output, ' END')
|
||||
end;
|
||||
|
||||
proc transpile_pointer_type(context: PTranspilerContext, type_expression: PAstTypeExpression);
|
||||
var
|
||||
token: LexerToken;
|
||||
begin
|
||||
WriteString(context^.output, 'POINTER TO ');
|
||||
|
||||
transpile_type_expression(context, type_expression^.target)
|
||||
end;
|
||||
|
||||
proc transpile_array_type(context: PTranspilerContext, type_expression: PAstTypeExpression);
|
||||
var
|
||||
buffer: [20]CHAR;
|
||||
begin
|
||||
WriteString(context^.output, 'ARRAY');
|
||||
|
||||
if type_expression^.length <> 0 then
|
||||
WriteString(context^.output, '[1..');
|
||||
|
||||
IntToStr(type_expression^.length, 0, buffer);
|
||||
WriteString(context^.output, buffer);
|
||||
|
||||
WriteChar(context^.output, ']')
|
||||
end;
|
||||
WriteString(context^.output, ' OF ');
|
||||
|
||||
transpile_type_expression(context, type_expression^.base)
|
||||
end;
|
||||
|
||||
proc transpile_enumeration_type(context: PTranspilerContext, type_expression: PAstTypeExpression);
|
||||
var
|
||||
current_case: PIdentifier;
|
||||
written_bytes: CARDINAL;
|
||||
begin
|
||||
current_case := type_expression^.cases;
|
||||
|
||||
WriteString(context^.output, '(');
|
||||
WriteLine(context^.output);
|
||||
WriteString(context^.output, ' ');
|
||||
written_bytes := WriteNBytes(context^.output, ORD(current_case^[1]), ADR(current_case^[2]));
|
||||
INC(current_case, TSIZE(Identifier));
|
||||
|
||||
while ORD(current_case^[1]) <> 0 do
|
||||
WriteChar(context^.output, ',');
|
||||
WriteLine(context^.output);
|
||||
WriteString(context^.output, ' ');
|
||||
written_bytes := WriteNBytes(context^.output, ORD(current_case^[1]), ADR(current_case^[2]));
|
||||
|
||||
INC(current_case, TSIZE(Identifier))
|
||||
end;
|
||||
WriteLine(context^.output);
|
||||
WriteString(context^.output, ' )')
|
||||
end;
|
||||
|
||||
proc transpile_named_type(context: PTranspilerContext, type_expression: PAstTypeExpression);
|
||||
var
|
||||
written_bytes: CARDINAL;
|
||||
begin
|
||||
written_bytes := WriteNBytes(context^.output, ORD(type_expression^.name[1]), ADR(type_expression^.name[2]))
|
||||
end;
|
||||
|
||||
proc transpile_procedure_type(context: PTranspilerContext, type_expression: PAstTypeExpression);
|
||||
var
|
||||
result: PAstTypeExpression;
|
||||
current_parameter: PPAstTypeExpression;
|
||||
parameter_count: CARDINAL;
|
||||
begin
|
||||
WriteString(context^.output, 'PROCEDURE(');
|
||||
current_parameter := type_expression^.parameters;
|
||||
|
||||
while current_parameter^ <> nil do
|
||||
transpile_type_expression(context, current_parameter^);
|
||||
|
||||
INC(current_parameter, TSIZE(PAstTypeExpression));
|
||||
|
||||
if current_parameter^ <> nil then
|
||||
WriteString(context^.output, ', ')
|
||||
end
|
||||
end;
|
||||
WriteChar(context^.output, ')')
|
||||
end;
|
||||
|
||||
proc transpile_type_expression(context: PTranspilerContext, type_expression: PAstTypeExpression);
|
||||
begin
|
||||
if type_expression^.kind = astTypeExpressionKindRecord then
|
||||
transpile_record_type(context, type_expression)
|
||||
end;
|
||||
if type_expression^.kind = astTypeExpressionKindEnumeration then
|
||||
transpile_enumeration_type(context, type_expression)
|
||||
end;
|
||||
if type_expression^.kind = astTypeExpressionKindArray then
|
||||
transpile_array_type(context, type_expression)
|
||||
end;
|
||||
if type_expression^.kind = astTypeExpressionKindPointer then
|
||||
transpile_pointer_type(context, type_expression)
|
||||
end;
|
||||
if type_expression^.kind = astTypeExpressionKindProcedure then
|
||||
transpile_procedure_type(context, type_expression)
|
||||
end;
|
||||
if type_expression^.kind = astTypeExpressionKindNamed then
|
||||
transpile_named_type(context, type_expression)
|
||||
end
|
||||
end;
|
||||
|
||||
proc transpile_type_declaration(context: PTranspilerContext, declaration: PAstTypeDeclaration);
|
||||
var
|
||||
written_bytes: CARDINAL;
|
||||
begin
|
||||
WriteString(context^.output, ' ');
|
||||
|
||||
written_bytes := WriteNBytes(context^.output, ORD(declaration^.identifier[1]), ADR(declaration^.identifier[2]));
|
||||
WriteString(context^.output, ' = ');
|
||||
|
||||
transpile_type_expression(context, declaration^.type_expression);
|
||||
write_semicolon(context^.output)
|
||||
end;
|
||||
|
||||
proc transpile_type_part(context: PTranspilerContext, declarations: PPAstTypeDeclaration);
|
||||
var
|
||||
current_declaration: PPAstTypeDeclaration;
|
||||
begin
|
||||
if declarations^ <> nil then
|
||||
WriteString(context^.output, 'TYPE');
|
||||
WriteLine(context^.output);
|
||||
|
||||
current_declaration := declarations;
|
||||
while current_declaration^ <> nil do
|
||||
transpile_type_declaration(context, current_declaration^);
|
||||
|
||||
INC(current_declaration, TSIZE(PAstTypeDeclaration))
|
||||
end;
|
||||
WriteLine(context^.output)
|
||||
end
|
||||
end;
|
||||
|
||||
proc transpile_variable_declaration(context: PTranspilerContext, declaration: PAstVariableDeclaration);
|
||||
var
|
||||
written_bytes: CARDINAL;
|
||||
begin
|
||||
WriteString(context^.output, ' ');
|
||||
written_bytes := WriteNBytes(context^.output, ORD(declaration^.variable_name[1]), ADR(declaration^.variable_name[2]));
|
||||
|
||||
WriteString(context^.output, ': ');
|
||||
|
||||
transpile_type_expression(context, declaration^.variable_type);
|
||||
write_semicolon(context^.output)
|
||||
end;
|
||||
|
||||
proc transpile_variable_part(context: PTranspilerContext, declarations: PPAstVariableDeclaration);
|
||||
var
|
||||
current_declaration: PPAstVariableDeclaration;
|
||||
begin
|
||||
if declarations^ <> nil then
|
||||
WriteString(context^.output, 'VAR');
|
||||
WriteLine(context^.output);
|
||||
|
||||
current_declaration := declarations;
|
||||
while current_declaration^ <> nil do
|
||||
transpile_variable_declaration(context, current_declaration^);
|
||||
|
||||
INC(current_declaration, TSIZE(PAstVariableDeclaration))
|
||||
end;
|
||||
WriteLine(context^.output)
|
||||
end
|
||||
end;
|
||||
|
||||
proc transpile_procedure_heading(context: PTranspilerContext) -> LexerToken;
|
||||
var
|
||||
token: LexerToken;
|
||||
result: LexerToken;
|
||||
type_expression: PAstTypeExpression;
|
||||
begin
|
||||
WriteString(context^.output, 'PROCEDURE ');
|
||||
|
||||
result := transpiler_lex(context^.lexer);
|
||||
write_current(context^.lexer, context^.output);
|
||||
|
||||
token := transpiler_lex(context^.lexer);
|
||||
WriteChar(context^.output, '(');
|
||||
|
||||
token := transpiler_lex(context^.lexer);
|
||||
while token.kind <> lexerKindRightParen do
|
||||
write_current(context^.lexer, context^.output);
|
||||
|
||||
token := transpiler_lex(context^.lexer);
|
||||
WriteString(context^.output, ': ');
|
||||
token := transpiler_lex(context^.lexer);
|
||||
|
||||
type_expression := parse_type_expression(context^.lexer);
|
||||
transpile_type_expression(context, type_expression);
|
||||
|
||||
token := transpiler_lex(context^.lexer);
|
||||
if (token.kind = lexerKindSemicolon) or (token.kind = lexerKindComma) then
|
||||
WriteString(context^.output, '; ');
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end
|
||||
end;
|
||||
WriteString(context^.output, ')');
|
||||
token := transpiler_lex(context^.lexer);
|
||||
|
||||
(* Check for the return type and write it. *)
|
||||
if token.kind = lexerKindArrow then
|
||||
WriteString(context^.output, ': ');
|
||||
token := transpiler_lex(context^.lexer);
|
||||
write_current(context^.lexer, context^.output);
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end;
|
||||
token := transpiler_lex(context^.lexer);
|
||||
write_semicolon(context^.output);
|
||||
|
||||
return result
|
||||
end;
|
||||
|
||||
proc transpile_expression(context: PTranspilerContext, trailing_token: LexerKind);
|
||||
var
|
||||
token: LexerToken;
|
||||
written_bytes: CARDINAL;
|
||||
begin
|
||||
token := transpiler_lex(context^.lexer);
|
||||
|
||||
while (token.kind <> trailing_token) & (token.kind <> lexerKindEnd) do
|
||||
written_bytes := 0;
|
||||
if token.kind = lexerKindNull then
|
||||
WriteString(context^.output, 'NIL ');
|
||||
written_bytes := 1
|
||||
end;
|
||||
if (token.kind = lexerKindBoolean) & token.booleanKind then
|
||||
WriteString(context^.output, 'TRUE ');
|
||||
written_bytes := 1
|
||||
end;
|
||||
if (token.kind = lexerKindBoolean) & (~token.booleanKind) then
|
||||
WriteString(context^.output, 'FALSE ');
|
||||
written_bytes := 1
|
||||
end;
|
||||
if token.kind = lexerKindOr then
|
||||
WriteString(context^.output, 'OR ');
|
||||
written_bytes := 1
|
||||
end;
|
||||
if token.kind = lexerKindAnd then
|
||||
WriteString(context^.output, 'AND ');
|
||||
written_bytes := 1
|
||||
end;
|
||||
if token.kind = lexerKindNot then
|
||||
WriteString(context^.output, 'NOT ');
|
||||
written_bytes := 1
|
||||
end;
|
||||
if written_bytes = 0 then
|
||||
write_current(context^.lexer, context^.output);
|
||||
WriteChar(context^.output, ' ')
|
||||
end;
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end
|
||||
end;
|
||||
|
||||
proc transpile_if_statement(context: PTranspilerContext);
|
||||
var
|
||||
token: LexerToken;
|
||||
begin
|
||||
WriteString(context^.output, ' IF ');
|
||||
transpile_expression(context, lexerKindThen);
|
||||
|
||||
WriteString(context^.output, 'THEN');
|
||||
WriteLine(context^.output);
|
||||
transpile_statements(context);
|
||||
WriteString(context^.output, ' END');
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end;
|
||||
|
||||
proc transpile_while_statement(context: PTranspilerContext);
|
||||
var
|
||||
token: LexerToken;
|
||||
begin
|
||||
WriteString(context^.output, ' WHILE ');
|
||||
transpile_expression(context, lexerKindDo);
|
||||
|
||||
WriteString(context^.output, 'DO');
|
||||
WriteLine(context^.output);
|
||||
transpile_statements(context);
|
||||
WriteString(context^.output, ' END');
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end;
|
||||
|
||||
proc transpile_assignment_statement(context: PTranspilerContext);
|
||||
begin
|
||||
WriteString(context^.output, ' := ');
|
||||
transpile_expression(context, lexerKindSemicolon);
|
||||
end;
|
||||
|
||||
proc transpile_call_statement(context: PTranspilerContext);
|
||||
var
|
||||
token: LexerToken;
|
||||
begin
|
||||
WriteString(context^.output, '(');
|
||||
token := transpiler_lex(context^.lexer);
|
||||
|
||||
while (token.kind <> lexerKindSemicolon) & (token.kind <> lexerKindEnd) do
|
||||
write_current(context^.lexer, context^.output);
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end
|
||||
end;
|
||||
|
||||
proc transpile_designator_expression(context: PTranspilerContext);
|
||||
var
|
||||
token: LexerToken;
|
||||
begin
|
||||
WriteString(context^.output, ' ');
|
||||
write_current(context^.lexer, context^.output);
|
||||
token := transpiler_lex(context^.lexer);
|
||||
|
||||
while token.kind = lexerKindLeftSquare do
|
||||
WriteChar(context^.output, '[');
|
||||
token := transpiler_lex(context^.lexer);
|
||||
while token.kind <> lexerKindRightSquare do
|
||||
write_current(context^.lexer, context^.output);
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end;
|
||||
WriteChar(context^.output, ']');
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end;
|
||||
if token.kind = lexerKindHat then
|
||||
WriteChar(context^.output, '^');
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end;
|
||||
if token.kind = lexerKindDot then
|
||||
WriteChar(context^.output, '.');
|
||||
token := transpiler_lex(context^.lexer);
|
||||
write_current(context^.lexer, context^.output);
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end;
|
||||
if token.kind = lexerKindHat then
|
||||
WriteChar(context^.output, '^');
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end;
|
||||
while token.kind = lexerKindLeftSquare do
|
||||
WriteChar(context^.output, '[');
|
||||
token := transpiler_lex(context^.lexer);
|
||||
while token.kind <> lexerKindRightSquare do
|
||||
write_current(context^.lexer, context^.output);
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end;
|
||||
WriteChar(context^.output, ']');
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end
|
||||
end;
|
||||
|
||||
proc transpile_return_statement(context: PTranspilerContext);
|
||||
var
|
||||
token: LexerToken;
|
||||
begin
|
||||
WriteString(context^.output, ' RETURN ');
|
||||
transpile_expression(context, lexerKindSemicolon)
|
||||
end;
|
||||
|
||||
proc transpile_statement(context: PTranspilerContext);
|
||||
var
|
||||
token: LexerToken;
|
||||
begin
|
||||
token := transpiler_lex(context^.lexer);
|
||||
|
||||
if token.kind = lexerKindIf then
|
||||
transpile_if_statement(context)
|
||||
end;
|
||||
if token.kind = lexerKindWhile then
|
||||
transpile_while_statement(context)
|
||||
end;
|
||||
if token.kind = lexerKindReturn then
|
||||
transpile_return_statement(context)
|
||||
end;
|
||||
if token.kind = lexerKindIdentifier then
|
||||
transpile_designator_expression(context);
|
||||
token := lexer_current(context^.lexer);
|
||||
|
||||
if token.kind = lexerKindAssignment then
|
||||
transpile_assignment_statement(context)
|
||||
end;
|
||||
if token.kind = lexerKindLeftParen then
|
||||
transpile_call_statement(context)
|
||||
end
|
||||
end
|
||||
end;
|
||||
|
||||
proc transpile_statements(context: PTranspilerContext);
|
||||
var
|
||||
token: LexerToken;
|
||||
begin
|
||||
token := lexer_current(context^.lexer);
|
||||
|
||||
while token.kind <> lexerKindEnd do
|
||||
transpile_statement(context);
|
||||
token := lexer_current(context^.lexer);
|
||||
|
||||
if token.kind = lexerKindSemicolon then
|
||||
WriteChar(context^.output, ';')
|
||||
end;
|
||||
WriteLine(context^.output)
|
||||
end
|
||||
end;
|
||||
|
||||
proc transpile_statement_part(context: PTranspilerContext);
|
||||
var
|
||||
token: LexerToken;
|
||||
begin
|
||||
token := lexer_current(context^.lexer);
|
||||
if token.kind = lexerKindBegin then
|
||||
WriteString(context^.output, 'BEGIN');
|
||||
WriteLine(context^.output);
|
||||
transpile_statements(context)
|
||||
end
|
||||
end;
|
||||
|
||||
proc transpile_procedure_declaration(context: PTranspilerContext);
|
||||
var
|
||||
token: LexerToken;
|
||||
seen_variables: PPAstVariableDeclaration;
|
||||
written_bytes: CARDINAL;
|
||||
seen_constants: PPAstConstantDeclaration;
|
||||
begin
|
||||
token := transpile_procedure_heading(context);
|
||||
seen_constants := parse_constant_part(context^.lexer);
|
||||
transpile_constant_part(context, seen_constants);
|
||||
|
||||
seen_variables := parse_variable_part(context^.lexer);
|
||||
transpile_variable_part(context, seen_variables);
|
||||
transpile_statement_part(context);
|
||||
|
||||
WriteString(context^.output, 'END ');
|
||||
written_bytes := WriteNBytes(context^.output, ORD(token.identifierKind[1]), ADR(token.identifierKind[2]));
|
||||
|
||||
token := transpiler_lex(context^.lexer);
|
||||
write_semicolon(context^.output);
|
||||
token := transpiler_lex(context^.lexer)
|
||||
end;
|
||||
|
||||
proc transpile_procedure_part(context: PTranspilerContext);
|
||||
var
|
||||
token: LexerToken;
|
||||
begin
|
||||
token := lexer_current(context^.lexer);
|
||||
|
||||
while token.kind = lexerKindProc do
|
||||
transpile_procedure_declaration(context);
|
||||
token := lexer_current(context^.lexer);
|
||||
WriteLine(context^.output)
|
||||
end
|
||||
end;
|
||||
|
||||
proc transpile_module_name(context: PTranspilerContext);
|
||||
var
|
||||
counter: CARDINAL;
|
||||
last_slash: CARDINAL;
|
||||
begin
|
||||
counter := 1;
|
||||
last_slash := 0;
|
||||
|
||||
while (context^.input_name[counter] <> '.') & (ORD(context^.input_name[counter]) <> 0) do
|
||||
if context^.input_name[counter] = '/' then
|
||||
last_slash := counter
|
||||
end;
|
||||
INC(counter)
|
||||
end;
|
||||
|
||||
if last_slash = 0 then
|
||||
counter := 1
|
||||
end;
|
||||
if last_slash <> 0 then
|
||||
counter := last_slash + 1
|
||||
end;
|
||||
while (context^.input_name[counter] <> '.') & (ORD(context^.input_name[counter]) <> 0) do
|
||||
WriteChar(context^.output, context^.input_name[counter]);
|
||||
INC(counter)
|
||||
end;
|
||||
end;
|
||||
|
||||
proc transpile(lexer: PLexer, output: File, input_name: ShortString);
|
||||
var
|
||||
token: LexerToken;
|
||||
context: TranspilerContext;
|
||||
ast_module: PAstModule;
|
||||
begin
|
||||
context.input_name := input_name;
|
||||
context.output := output;
|
||||
context.lexer := lexer;
|
||||
|
||||
ast_module := transpile_module(ADR(context))
|
||||
end;
|
||||
|
||||
end.
|
||||
62
src/Main.hs
Normal file
62
src/Main.hs
Normal 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
82
tests/Language/Elna/NameAnalysisSpec.hs
Normal 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
146
tests/Language/Elna/ParserSpec.hs
Normal 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
5
tests/Spec.hs
Normal 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
1
tests/expectations/add_products.txt
Normal file
@ -0,0 +1 @@
|
||||
38
|
||||
1
tests/expectations/add_to_variable.txt
Normal file
1
tests/expectations/add_to_variable.txt
Normal file
@ -0,0 +1 @@
|
||||
58
|
||||
1
tests/expectations/array_element_assignment.txt
Normal file
1
tests/expectations/array_element_assignment.txt
Normal file
@ -0,0 +1 @@
|
||||
5
|
||||
2
tests/expectations/array_with_variable_index.txt
Normal file
2
tests/expectations/array_with_variable_index.txt
Normal file
@ -0,0 +1,2 @@
|
||||
5
|
||||
7
|
||||
1
tests/expectations/define_variable.txt
Normal file
1
tests/expectations/define_variable.txt
Normal file
@ -0,0 +1 @@
|
||||
58
|
||||
1
tests/expectations/exit_between_statements.txt
Normal file
1
tests/expectations/exit_between_statements.txt
Normal file
@ -0,0 +1 @@
|
||||
c
|
||||
1
tests/expectations/parse_negative_numbers.txt
Normal file
1
tests/expectations/parse_negative_numbers.txt
Normal file
@ -0,0 +1 @@
|
||||
-8
|
||||
1
tests/expectations/print0.txt
Normal file
1
tests/expectations/print0.txt
Normal file
@ -0,0 +1 @@
|
||||
0
|
||||
1
tests/expectations/print_2_digits.txt
Normal file
1
tests/expectations/print_2_digits.txt
Normal file
@ -0,0 +1 @@
|
||||
13
|
||||
2
tests/expectations/print_2_statements.txt
Normal file
2
tests/expectations/print_2_statements.txt
Normal file
@ -0,0 +1,2 @@
|
||||
13
|
||||
2097150
|
||||
1
tests/expectations/print_after_loop.txt
Normal file
1
tests/expectations/print_after_loop.txt
Normal file
@ -0,0 +1 @@
|
||||
2
|
||||
2
tests/expectations/print_array_element.txt
Normal file
2
tests/expectations/print_array_element.txt
Normal file
@ -0,0 +1,2 @@
|
||||
5
|
||||
7
|
||||
1
tests/expectations/print_char.txt
Normal file
1
tests/expectations/print_char.txt
Normal file
@ -0,0 +1 @@
|
||||
x
|
||||
2
tests/expectations/print_in_proc.txt
Normal file
2
tests/expectations/print_in_proc.txt
Normal file
@ -0,0 +1,2 @@
|
||||
14
|
||||
8
|
||||
1
tests/expectations/print_more_20_bits.txt
Normal file
1
tests/expectations/print_more_20_bits.txt
Normal file
@ -0,0 +1 @@
|
||||
2097150
|
||||
1
tests/expectations/print_negate.txt
Normal file
1
tests/expectations/print_negate.txt
Normal file
@ -0,0 +1 @@
|
||||
-8
|
||||
1
tests/expectations/print_product.txt
Normal file
1
tests/expectations/print_product.txt
Normal file
@ -0,0 +1 @@
|
||||
1000
|
||||
1
tests/expectations/print_subtraction.txt
Normal file
1
tests/expectations/print_subtraction.txt
Normal file
@ -0,0 +1 @@
|
||||
-8
|
||||
1
tests/expectations/print_sum.txt
Normal file
1
tests/expectations/print_sum.txt
Normal file
@ -0,0 +1 @@
|
||||
18
|
||||
1
tests/expectations/printi_hex.txt
Normal file
1
tests/expectations/printi_hex.txt
Normal file
@ -0,0 +1 @@
|
||||
129
|
||||
1
tests/expectations/printi_if.txt
Normal file
1
tests/expectations/printi_if.txt
Normal file
@ -0,0 +1 @@
|
||||
3
|
||||
1
tests/expectations/printi_if_greater.txt
Normal file
1
tests/expectations/printi_if_greater.txt
Normal file
@ -0,0 +1 @@
|
||||
5
|
||||
1
tests/expectations/printi_if_greater_equal.txt
Normal file
1
tests/expectations/printi_if_greater_equal.txt
Normal file
@ -0,0 +1 @@
|
||||
5
|
||||
1
tests/expectations/printi_if_less.txt
Normal file
1
tests/expectations/printi_if_less.txt
Normal file
@ -0,0 +1 @@
|
||||
3
|
||||
1
tests/expectations/printi_if_less_equal.txt
Normal file
1
tests/expectations/printi_if_less_equal.txt
Normal file
@ -0,0 +1 @@
|
||||
3
|
||||
1
tests/expectations/printi_if_not.txt
Normal file
1
tests/expectations/printi_if_not.txt
Normal file
@ -0,0 +1 @@
|
||||
3
|
||||
2
tests/expectations/printi_if_not_compound.txt
Normal file
2
tests/expectations/printi_if_not_compound.txt
Normal file
@ -0,0 +1,2 @@
|
||||
3
|
||||
7
|
||||
1
tests/expectations/printi_negative_hex.txt
Normal file
1
tests/expectations/printi_negative_hex.txt
Normal file
@ -0,0 +1 @@
|
||||
-129
|
||||
1
tests/expectations/printi_quotient.txt
Normal file
1
tests/expectations/printi_quotient.txt
Normal file
@ -0,0 +1 @@
|
||||
2
|
||||
1
tests/expectations/printi_signed_hex.txt
Normal file
1
tests/expectations/printi_signed_hex.txt
Normal file
@ -0,0 +1 @@
|
||||
129
|
||||
2
tests/expectations/two_variables.txt
Normal file
2
tests/expectations/two_variables.txt
Normal file
@ -0,0 +1,2 @@
|
||||
58
|
||||
28
|
||||
3
tests/vm/add_products.elna
Normal file
3
tests/vm/add_products.elna
Normal file
@ -0,0 +1,3 @@
|
||||
proc main() {
|
||||
printi(2 * 3 + 4 * 8);
|
||||
}
|
||||
6
tests/vm/add_to_variable.elna
Normal file
6
tests/vm/add_to_variable.elna
Normal file
@ -0,0 +1,6 @@
|
||||
proc main() {
|
||||
var i: int;
|
||||
i := 28;
|
||||
|
||||
printi(i + 30);
|
||||
}
|
||||
6
tests/vm/array_element_assignment.elna
Normal file
6
tests/vm/array_element_assignment.elna
Normal 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
11
tests/vm/array_with_variable_index.elna
Normal 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
6
tests/vm/define_variable.elna
Normal file
@ -0,0 +1,6 @@
|
||||
proc main() {
|
||||
var i: int;
|
||||
i := 58;
|
||||
|
||||
printi(i);
|
||||
}
|
||||
5
tests/vm/exit_between_statements.elna
Normal file
5
tests/vm/exit_between_statements.elna
Normal file
@ -0,0 +1,5 @@
|
||||
proc main() {
|
||||
printc('c');
|
||||
exit();
|
||||
printi(1234);
|
||||
}
|
||||
3
tests/vm/parse_negative_numbers.elna
Normal file
3
tests/vm/parse_negative_numbers.elna
Normal file
@ -0,0 +1,3 @@
|
||||
proc main() {
|
||||
printi(-8);
|
||||
}
|
||||
3
tests/vm/print0.elna
Normal file
3
tests/vm/print0.elna
Normal file
@ -0,0 +1,3 @@
|
||||
proc main() {
|
||||
printi(0);
|
||||
}
|
||||
3
tests/vm/print_2_digits.elna
Normal file
3
tests/vm/print_2_digits.elna
Normal file
@ -0,0 +1,3 @@
|
||||
proc main() {
|
||||
printi(13);
|
||||
}
|
||||
4
tests/vm/print_2_statements.elna
Normal file
4
tests/vm/print_2_statements.elna
Normal file
@ -0,0 +1,4 @@
|
||||
proc main() {
|
||||
printi(13);
|
||||
printi(2097150);
|
||||
}
|
||||
9
tests/vm/print_after_loop.elna
Normal file
9
tests/vm/print_after_loop.elna
Normal 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
8
tests/vm/print_array_element.elna
Normal 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]);
|
||||
}
|
||||
3
tests/vm/print_char.elna
Normal file
3
tests/vm/print_char.elna
Normal file
@ -0,0 +1,3 @@
|
||||
proc main() {
|
||||
printc('x');
|
||||
}
|
||||
8
tests/vm/print_in_proc.elna
Normal file
8
tests/vm/print_in_proc.elna
Normal file
@ -0,0 +1,8 @@
|
||||
proc print2(a: int, b: int) {
|
||||
printi(a);
|
||||
printi(b);
|
||||
}
|
||||
|
||||
proc main() {
|
||||
print2(14, 8);
|
||||
}
|
||||
3
tests/vm/print_more_20_bits.elna
Normal file
3
tests/vm/print_more_20_bits.elna
Normal file
@ -0,0 +1,3 @@
|
||||
proc main() {
|
||||
printi(2097150);
|
||||
}
|
||||
3
tests/vm/print_negate.elna
Normal file
3
tests/vm/print_negate.elna
Normal file
@ -0,0 +1,3 @@
|
||||
proc main() {
|
||||
printi(-(8));
|
||||
}
|
||||
3
tests/vm/print_product.elna
Normal file
3
tests/vm/print_product.elna
Normal file
@ -0,0 +1,3 @@
|
||||
proc main() {
|
||||
printi(20 * 50);
|
||||
}
|
||||
3
tests/vm/print_subtraction.elna
Normal file
3
tests/vm/print_subtraction.elna
Normal file
@ -0,0 +1,3 @@
|
||||
proc main() {
|
||||
printi(5 - 13);
|
||||
}
|
||||
3
tests/vm/print_sum.elna
Normal file
3
tests/vm/print_sum.elna
Normal file
@ -0,0 +1,3 @@
|
||||
proc main() {
|
||||
printi(5 + 13);
|
||||
}
|
||||
3
tests/vm/printi_hex.elna
Normal file
3
tests/vm/printi_hex.elna
Normal file
@ -0,0 +1,3 @@
|
||||
proc main() {
|
||||
printi(0x81);
|
||||
}
|
||||
4
tests/vm/printi_if.elna
Normal file
4
tests/vm/printi_if.elna
Normal file
@ -0,0 +1,4 @@
|
||||
proc main() {
|
||||
if (1 = 1)
|
||||
printi(3);
|
||||
}
|
||||
6
tests/vm/printi_if_greater.elna
Normal file
6
tests/vm/printi_if_greater.elna
Normal file
@ -0,0 +1,6 @@
|
||||
proc main() {
|
||||
if ((1 + 1) > 2)
|
||||
printi(3);
|
||||
else
|
||||
printi(5);
|
||||
}
|
||||
6
tests/vm/printi_if_greater_equal.elna
Normal file
6
tests/vm/printi_if_greater_equal.elna
Normal file
@ -0,0 +1,6 @@
|
||||
proc main() {
|
||||
if ((1 + 1) >= (2 + 3))
|
||||
printi(3);
|
||||
else
|
||||
printi(5);
|
||||
}
|
||||
6
tests/vm/printi_if_less.elna
Normal file
6
tests/vm/printi_if_less.elna
Normal file
@ -0,0 +1,6 @@
|
||||
proc main() {
|
||||
if (1 < 2)
|
||||
printi(3);
|
||||
else
|
||||
printi(5);
|
||||
}
|
||||
6
tests/vm/printi_if_less_equal.elna
Normal file
6
tests/vm/printi_if_less_equal.elna
Normal file
@ -0,0 +1,6 @@
|
||||
proc main() {
|
||||
if (2 <= (2 + 1))
|
||||
printi(3);
|
||||
else
|
||||
printi(5);
|
||||
}
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
x
Reference in New Issue
Block a user