Compare commits

...

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

108 changed files with 5052 additions and 2546 deletions

7
.gitignore vendored
View File

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

1
.ruby-version Normal file
View File

@ -0,0 +1 @@
3.3.6

373
LICENSE Normal file
View 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
View File

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

View File

@ -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
View File

@ -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
View File

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

88
elna.cabal Normal file
View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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
View File

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

100
rakelib/tester.rake Normal file
View File

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

View File

@ -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.

View File

@ -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.

View File

@ -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.

View File

@ -1,3 +0,0 @@
module;
end.

View File

@ -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.

View File

@ -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.

View File

@ -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.

View File

@ -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.

View File

@ -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.

View File

@ -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.

View File

@ -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
View File

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

View File

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

View File

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

5
tests/Spec.hs Normal file
View File

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

View File

@ -0,0 +1 @@
38

View File

@ -0,0 +1 @@
58

View File

@ -0,0 +1 @@
5

View File

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

View File

@ -0,0 +1 @@
58

View File

@ -0,0 +1 @@
c

View File

@ -0,0 +1 @@
-8

View File

@ -0,0 +1 @@
0

View File

@ -0,0 +1 @@
13

View File

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

View File

@ -0,0 +1 @@
2

View File

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

View File

@ -0,0 +1 @@
x

View File

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

View File

@ -0,0 +1 @@
2097150

View File

@ -0,0 +1 @@
-8

View File

@ -0,0 +1 @@
1000

View File

@ -0,0 +1 @@
-8

View File

@ -0,0 +1 @@
18

View File

@ -0,0 +1 @@
129

View File

@ -0,0 +1 @@
3

View File

@ -0,0 +1 @@
5

View File

@ -0,0 +1 @@
5

View File

@ -0,0 +1 @@
3

View File

@ -0,0 +1 @@
3

View File

@ -0,0 +1 @@
3

View File

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

View File

@ -0,0 +1 @@
-129

View File

@ -0,0 +1 @@
2

View File

@ -0,0 +1 @@
129

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

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

View File

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

View File

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

View File

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

View File

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

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

@ -0,0 +1,3 @@
proc main() {
printc('x');
}

View File

@ -0,0 +1,8 @@
proc print2(a: int, b: int) {
printi(a);
printi(b);
}
proc main() {
print2(14, 8);
}

View File

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

View File

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

View File

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

View File

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

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

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

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

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

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

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

View File

@ -0,0 +1,6 @@
proc main() {
if ((1 + 1) > 2)
printi(3);
else
printi(5);
}

View File

@ -0,0 +1,6 @@
proc main() {
if ((1 + 1) >= (2 + 3))
printi(3);
else
printi(5);
}

View File

@ -0,0 +1,6 @@
proc main() {
if (1 < 2)
printi(3);
else
printi(5);
}

View 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