├── .ghci
├── .github
└── workflows
│ └── main.yml
├── .gitignore
├── .gitmodules
├── .hlint.yaml
├── .stylish-haskell.yaml
├── .travis.yml
├── .travis
├── deploy_key.enc
├── install-dhall-to-yaml.sh
├── install-stack.sh
├── requirements.txt
└── visualize-test.sh
├── ChangeLog.md
├── LICENSE
├── README.md
├── Setup.hs
├── app
└── Main.hs
├── assets
├── example_ast
│ ├── calc.png
│ └── fizzbuzz.png
└── some_operation.gif
├── bench
└── Criterion.hs
├── docker
├── Dockerfile
├── example.dhall
└── test.dhall
├── example
├── Makefile
├── knapsack.c
├── lifegame.c
├── merge_sorting_linked_list.c
└── shuffle_and_sort.c
├── htcc.cabal
├── package.yaml
├── src
└── Htcc
│ ├── Asm.hs
│ ├── Asm
│ ├── Generate.hs
│ ├── Generate
│ │ └── Core.hs
│ ├── Intrinsic.hs
│ └── Intrinsic
│ │ ├── Operand.hs
│ │ ├── Register.hs
│ │ ├── Structure.hs
│ │ └── Structure
│ │ ├── Internal.hs
│ │ └── Section
│ │ ├── Data.hs
│ │ ├── Text.hs
│ │ └── Text
│ │ ├── Directive.hs
│ │ ├── Instruction.hs
│ │ └── Operations.hs
│ ├── CRules.hs
│ ├── CRules
│ ├── Char.hs
│ ├── LexicalElements.hs
│ ├── Preprocessor.hs
│ ├── Preprocessor
│ │ ├── Core.hs
│ │ └── Punctuators.hs
│ ├── Types.hs
│ └── Types
│ │ ├── CType.hs
│ │ ├── StorageClass.hs
│ │ └── TypeKind.hs
│ ├── Parser.hs
│ ├── Parser
│ ├── AST.hs
│ ├── AST
│ │ ├── Core.hs
│ │ ├── DeduceKind.hs
│ │ ├── Type.hs
│ │ ├── Var.hs
│ │ └── Var
│ │ │ └── Init.hs
│ ├── ConstructionData.hs
│ ├── ConstructionData
│ │ ├── Core.hs
│ │ ├── Scope.hs
│ │ └── Scope
│ │ │ ├── Enumerator.hs
│ │ │ ├── Function.hs
│ │ │ ├── ManagedScope.hs
│ │ │ ├── Tag.hs
│ │ │ ├── Typedef.hs
│ │ │ ├── Utils.hs
│ │ │ └── Var.hs
│ ├── Parsing.hs
│ ├── Parsing
│ │ ├── Core.hs
│ │ ├── Core.hs-boot
│ │ ├── Global.hs
│ │ ├── Global.hs-boot
│ │ ├── Global
│ │ │ ├── Function.hs
│ │ │ └── Var.hs
│ │ ├── StmtExpr.hs
│ │ ├── Type.hs
│ │ └── Typedef.hs
│ ├── Utils.hs
│ └── Utils
│ │ └── Core.hs
│ ├── Tokenizer.hs
│ ├── Tokenizer
│ ├── Core.hs
│ └── Token.hs
│ ├── Utils.hs
│ ├── Utils
│ ├── Bool.hs
│ ├── CompilationState.hs
│ ├── List.hs
│ ├── NaturalTransformations.hs
│ ├── Print.hs
│ ├── Text.hs
│ └── Tuple.hs
│ ├── Visualizer.hs
│ └── Visualizer
│ └── Core.hs
├── stack.yaml
├── stack.yaml.lock
└── test
├── Spec.hs
└── Tests
├── SubProcTests.hs
├── Test1.hs
├── Test2.hs
├── Test3.hs
├── Utils.hs
└── csrc
├── test_core.c
├── test_func1.c
├── test_func2.c
├── test_func3.c
├── test_func4.c
└── test_utils.h
/.ghci:
--------------------------------------------------------------------------------
1 | import qualified Data.Text as T
2 | import qualified Data.Map as M
3 | import qualified Data.Sequence as SQ
4 | import Data.Either
5 | import Data.Maybe
6 | import Numeric.Natural
7 | import Control.Exception
8 | import Control.Monad
9 |
10 | :set -XOverloadedStrings
11 |
12 |
--------------------------------------------------------------------------------
/.github/workflows/main.yml:
--------------------------------------------------------------------------------
1 | name: CI
2 | on:
3 | push:
4 | branches:
5 | - master
6 | - develop
7 |
8 | jobs:
9 | test:
10 | name: htcc test
11 | runs-on: ${{ matrix.os }}
12 | strategy:
13 | matrix:
14 | os:
15 | - ubuntu-18.04
16 | - ubuntu-20.04
17 | # - windows-latest
18 | # - macos-latest
19 | ghc: ["8.6.5"]
20 | cabal: ["3.0"]
21 | steps:
22 | - uses: actions/checkout@v2
23 | - name: Setup Haskell to ${{ matrix.os }} (GHC ${{ matrix.ghc }})
24 | uses: actions/setup-haskell@v1.1.4
25 | with:
26 | enable-stack: true
27 | stack-setup-ghc: true
28 | ghc-version: ${{ matrix.ghc }}
29 | cabal-version: ${{ matrix.cabal }}
30 | - name: Cache
31 | uses: actions/cache@v2
32 | id: stack-cache
33 | with:
34 | path: ~/.stack
35 | key: stack-v3-${{ runner.os }}-${{ hashFiles('stack.yaml') }}
36 | - name: Setup Dhall to yaml
37 | if: runner.os == 'Linux'
38 | run: .travis/install-dhall-to-yaml.sh
39 | - name: Add path
40 | run: echo "$HOME/.local/bin" >> $GITHUB_PATH
41 | - name: Install dependencies to ${{ matrix.os }}
42 | run: stack build --only-dependencies
43 | - name: Build htcc to ${{ matrix.os }}
44 | run: stack install
45 | - name: Test htcc on ${{ matrix.os }}
46 | if: runner.os == 'Linux'
47 | run: |
48 | stack test --test-arguments self
49 | stack test --test-arguments subp
50 | - name: Compile and execute example C codes on ${{ matrix.os }}
51 | if: runner.os == 'Linux'
52 | run: |
53 | make
54 | cd dist
55 | ./knapsack && ./merge_sorting_linked_list && ./shuffle_and_sort
56 | working-directory: ./example
57 | - name: Test htcc on ${{ matrix.os }} with Docker
58 | run: |
59 | stack test --test-arguments docker
60 | stack test --test-arguments docker --test-arguments --clean
61 | - name: Compile and execute example C codes on ${{ matrix.os }} with Docker
62 | run: |
63 | make docker
64 | make clean_docker
65 | working-directory: ./example
66 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | .stack-work
2 | *.swp
3 | bench_report.html
4 | docs/
5 | example/dist
6 |
--------------------------------------------------------------------------------
/.gitmodules:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/falgon/htcc/163a88588ecb75c53e8e5f60bc321bb43a4bb193/.gitmodules
--------------------------------------------------------------------------------
/.hlint.yaml:
--------------------------------------------------------------------------------
1 | - ignore:
2 | name: Reduce duplication
3 |
--------------------------------------------------------------------------------
/.stylish-haskell.yaml:
--------------------------------------------------------------------------------
1 | # stylish-haskell configuration file
2 | # ==================================
3 |
4 | steps:
5 | - simple_align:
6 | cases: true
7 | top_level_patterns: true
8 | records: true
9 | - imports:
10 | align: global
11 | list_align: after_alias
12 | pad_module_names: true
13 | long_list_align: inline
14 | empty_list_align: inherit
15 | list_padding: 4
16 | separate_lists: true
17 | space_surround: false
18 | - language_pragmas:
19 | style: compact
20 | align: true
21 | remove_redundant: true
22 | - tabs:
23 | spaces: 4
24 | - trailing_whitespace: {}
25 |
26 | columns: 80
27 | newline: lf
28 |
29 | language_extensions:
30 | - ExplicitNamespaces
31 |
--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
1 | os:
2 | - linux
3 | - osx
4 | arch: amd64
5 | dist: bionic
6 | language: generic
7 | cache:
8 | apt: true
9 | directories:
10 | - "$HOME/.stack/"
11 | - "$HOME/.local/bin/"
12 | - ".stack-work/"
13 | addons:
14 | apt:
15 | update: true
16 | packages:
17 | - imagemagick
18 | - gcc
19 | - python3-dev
20 | - python-dev
21 | - python3-pip
22 | - python3-setuptools
23 | homebrew:
24 | update: true
25 | packages:
26 | - imagemagick
27 | - gcc
28 | before_install:
29 | - |
30 | if [ "$TRAVIS_OS_NAME" == "linux" ] || [ "$TRAVIS_OS_NAME" == "osx" ]; then
31 | mkdir -p ~/.local/bin
32 | export PATH=$HOME/.local/bin:$PATH
33 | ./.travis/install-stack.sh
34 | ./.travis/install-dhall-to-yaml.sh
35 | fi
36 | echo -e "Host github.com\n\tStrictHostKeyChecking no\nIdentityFile ~/.ssh/deploy.key\n" >> ~/.ssh/config
37 | openssl aes-256-cbc -pass "pass:$SERVER_KEY" -pbkdf2 -in .travis/deploy_key.enc -d -a -out deploy.key
38 | mv deploy.key ~/.ssh/
39 | chmod 600 ~/.ssh/deploy.key
40 | git config --global user.email "falgon53@yahoo.co.jp"
41 | git config --global user.name "falgon"
42 | git config --global core.autocrlf "input"
43 | install:
44 | - stack --no-terminal test --only-dependencies
45 | - pip3 install -r .travis/requirements.txt --user
46 | jobs:
47 | include:
48 | - stage: Run build
49 | os: linux
50 | script: stack build
51 | - stage: Run build
52 | os: osx
53 | script: stack build --ghc-options="-optP-Wno-nonportable-include-path"
54 | - stage: Run compiler test
55 | os: linux
56 | script:
57 | - stack test --test-arguments self
58 | - stack test --test-arguments subp
59 | - stage: Run compiling and executing example C codes
60 | os: linux
61 | script:
62 | - cd example && make && cd dist && ./knapsack && ./merge_sorting_linked_list &&
63 | ./shuffle_and_sort
64 | - stage: Run generating AST graphs
65 | os: linux
66 | script:
67 | - "./.travis/visualize-test.sh"
68 | - stage: Run generating AST graphs
69 | os: osx
70 | script:
71 | - "./.travis/visualize-test.sh"
72 | - stage: Run compiler test on Docker
73 | os: linux
74 | services: docker
75 | script:
76 | - stack test --test-arguments docker
77 | - stack test --test-arguments docker --test-arguments --clean
78 | - stage: Run compiling and executing example C codes on Docker
79 | os: linux
80 | services: docker
81 | script:
82 | - cd example && make docker && make clean_docker
83 | - if: branch = master
84 | stage: Deploy gh-pages
85 | os: linux
86 | script:
87 | - stack clean
88 | - stack haddock --fast
89 | - ghp-import -m "by Travis CI (JOB $TRAVIS_JOB_NUMBER)" -n docs
90 | - git push -qf git@github.com:falgon/htcc.git gh-pages
91 | branches:
92 | except:
93 | - gh-pages
94 | - monadic
95 | notifications:
96 | email: false
97 | env:
98 | global:
99 | secure: Noyd9Ggg/V9GwT8Tm8EtKKpESoiYEGz+QG9NyrAGfU2I4Ij5Rry3mxc34uSFD9iZ5eR5HeY17ZwQuRhCAfLNrp1U94qL9zIIHpmSlQ1MVi5d0cgiLdpzGorj2uaBu1BfVoFNFQZXa0N0nrXAo8XONB8i172MsEe8D9FtHo137dYbbB0osaW5Dnm+qQIM5CfXno4a1ofN1nyCCh7dTiutr7JBgpUJjD2bprk+Hy8qCSqvCdO/h6FA36RMriSKAYdTaipd8AfT7GKS2/6aQgN4XtKollDqsksp9h1+txkuM/e52gDIjhxh0gmBBjV3lY2Nxkn7SPuwlWUJoknBnnhzrxOCHluRphvE/zPT0ps7K6LCG4Bl/Pt9kSbWaHODmK39HMd+aij2t7FN7jixxzyTImqWfv9DrHGLr/cTcmh9pjFe/9RgET+K9B/1LeuESev+YxvabIEBBS9KEiXxaO907WXqwKMsPgLEb5WSBGHUibsCE2F/O9JriQNckVPVygffAOyf7VpfGsIg2+guqLkpa/2n2ClfKzrYtcQc2Az85kT4X8/yV6HhLgSvxB1DRq+PGvgaDK6VZiIEkVmxNi+CCjXDXZD2IBwGGjL18w0fltf3yAGLvffjBCSoh23L6P423qyVjbLVNNPz6adkxXs6dQQXnLT7mrq3yfsXUzC1wqc=
100 |
--------------------------------------------------------------------------------
/.travis/deploy_key.enc:
--------------------------------------------------------------------------------
1 | U2FsdGVkX188GvhUdLQxZfzCIAvLtz8FhyCrsHBPmhomL1P8tjTcl97YHWCgswmJ
2 | 2nU3aUqXaY8tqyS6pNqMOSj8SQCf6iAPC4/5kFCR2nUmFF6/10/wGPF4dAQdWu02
3 | cTt2qrhX+0Fx5cK+tgUJO5DCs5NevtDYYcO7BktZ+wjdpu2DPbxoktRJn8vI0HMR
4 | 2m+tdAAE++UL7VNx8H5u2Qnonp/pwCkmPBd0AkFh6sVWxIfVmDm4HZBlE4s/z4vS
5 | t1jYWZiJ5fxUo+LBTdGBldct97BbRO1C7C6iPniWHu9y2M41xiGqqsH98wA/NsEc
6 | kXwWOeucUhNw3ePv9kLPTWlK5k55uK8JDfyYcDVagHpi03Ip2pMyAQj963phOtgI
7 | EP4QZ3+zdqSaLP5qXCxU8mGOCkAjqMIdi4EOPti0L/GMghrmEyjB1jwSDU2bDwnN
8 | 1O/UJAdTApQtM7z4WR97/vwKIYeb7WjDJBfoIf7K+TSuGtgxJU3UGD8Y42Wg7EfK
9 | kEUJlRlIJNLyjEorR5aFHzrvxwc0wB35wGpcPFqNw+fMBJuD5FqADdL69wR/1im9
10 | 4bNyswBmOuhVfh5e3hZ/7zPDE+FUNCBTfyo7cSHQNkMjzWWXXurY0a6Ifi9eWtjk
11 | Oy1OS+lIaCPV69s9tgSNyW2A7ZGKApWUmgs9/2wgnEbJkbZ9ph8SdKQghsjYJMWe
12 | UwsdMYkr0Z/SpEGnx6uoNVbN/pGfGu6WeoiuuEzf2M73MS81WTw6ihx09YEOko07
13 | oYUpdzqgL1f0TLb9VT1IxE8jyEW6iTIfrefV5er25hLU/3u/gH5LkwbOr4LlQmF/
14 | FrCWENvItcwe/8pJQPsJepn6aEKYWQIrUPLClFgpKVgs9VyRghD7GNEXUCNh0ZqU
15 | IHdOqOuwVvW7+rfpEM5tJT7X7vvRtCZoaK3waOh38TnzXo4KrMYdva8Z7nSjgQzu
16 | doSoDKF35XI+DEyMCfVPlrLf04d077ikjp4RNj12urjiviMBGNPValLf+oB/3irc
17 | rVlYmFm3ZUEfRHnNWxvxFB+Oq58Rz5y0i6miPR0NsB7ThRyVTOnlN5blLUCklcbF
18 | yp1bUFBskxL/Za1YoUAommJLCeW+z9Nn8DExe6vtQqDA3bGRi1CnLT1hy0lLW+S4
19 | q072DzIHlEHOMKTvs0g1gB7uzz6SEv5Lk7K5pl23dP9gMXP0uD7rbcoa2yoZabbV
20 | +AQkO3oToD+d01aBM2yGRNRGdzNUx96GpfoV+5VBDgUJ9gn/9vxbHmPWjuPqyO/3
21 | /grYcJWC/NKWTg5JC5+zchq6Gs5IeKgXLjQPfsUyWm1HqAidB8UgQEStZz7e7Xde
22 | ckZmSowoaeivST2gSkZB7Jkh+u8PLQuKgLdP1LWQB18afZBcGE6Vdwrqp4TE2eDc
23 | ALtdhwOL51v2mBvg257V3rNyOYqWGhkfmy4UCGhicGczBmWggaISrmjAulPFTVJ6
24 | 0pedcD9WTGbGbtIdDuGwwjyTTf6MmhEvYOlumtTFWEHM5OGBKJ/OndK+M+U1boUn
25 | bHfRTGoBtaQmWrgKmlGj1aRqYHBhVtBLp9NpFj5TXlFp95D8vB3dN6vLR/wKEfSU
26 | Ab8D0xqlVAVWA61XNrCEXmwZeBRgDk8FdY7h/ijQFZnCn7kUZ2x+3EL6V8Syp0YM
27 | b83wDUlZvztDePdnl8HoEgaQazu1ZmWSS5jyjIx6a0QUyGgmRhBH+5xzjta2yvVt
28 | MskOnig34GYJyumNeF8Y0cmu9DAgH0X366MqaXQXBri476zlZaYvF7DgS2vENuL3
29 | KZd9n0k8lOxv0E+iD6+cDRcau9FMHcIpYEvWyiAAHVtXZNtS9Qelo1VqHDHNw3Ob
30 | /gWUVfjXaeQoiqLvPnU88RQUk9I0kNQXbRcO6ODMMJGqOlJ/ZxYj2+qaGe0SoXsN
31 | qkO+2o1JZvAgbNX1pew+8VhjRPjz4z9TsN32upMuwqKv1ld9O7gAUAkbCaXQYOAn
32 | W5z0KD+RTSdOTxDjoXsGE24tD5TyTH1cCxjtt8Ev6uwfDHt4hRhBmO6RfBFFFjZI
33 | SVIYdVX6NdPNeuM1Lmk3YKDCXifUV97Q75+Kw+SCen2QGANX+3mXltHMKaV7G+UH
34 | o9Aywy37LE0qVo49xXKHhf+bvaOFsGoLUX6yl2ef23EJjH/gsAaKkVeufkFrHiAs
35 | BhS3rtBtJkSm+DdQn4vKYdfFNUjgRqEpQs4HFMkAlsaY6CIXE6Pkt21xcx0FPhKX
36 | rBgm5PJGSne+gnUi6M18WCRqGh9oiI35cY2D2vGwdl9e6QQOFiFW0UJQkKRIpKPF
37 | KBM91v4czXy5vwlvmigkW7q4ECoOn5ri6Asf91ZujxkDtEG7zuso3L2r8PfGwlHP
38 | KdMYMI/6S/FelZScNAX6KGj2ujOUDCpDUkyCoGuLlBR8JRsAYEF172p8mU5g8Wej
39 | kOd/fOKxDPrRSQe6Xv5E26VEyZWYkYf1KC1XlATB0YeWJPufipLnT1fsq2hlTYu+
40 | JJwB59QnFYSPQ2tWeAy+AJvzROPyjMG2gLsWfG6oudAHUJ3PLnrrol4pmLJVOGct
41 | 24FMHnTnIdKWS1rw4eEhPt6BigbamWbCRFGvWyPqyRPiideunK1vh7Gg+7FHFtPu
42 | bHD/3dcUawuf5A+KcYr6n5BbCA9foZzuy8OED9bpDDxvlWNfqGhw2wT72HxnAaQG
43 | GC5YgqJLlGHMSDA/NtJMxYMQB3G71s/FaxJaenXHhBc67N3057CBUmXraTUREuEF
44 | iRYGxqLnb3MaVUtX6oRGDDNXx/ZEXnKt3T93+ag6gkS6PokvSaTzJK5XY7zt+HsH
45 | FfDXnDZVe6+kEZrOKPBO3ZHLYTkCAQoSTNTyEylxMA//jwOjAVS5yQ3Q1A1W4A8S
46 | fdQ9nfLfSmSFa56CBbFUfGY1qR8Q2gb3bthd4xm5sRvvk40AtPRxY0fcUMh8Nsnz
47 | yAgSN8X/B6qPEMf3zBFPPRKo+ur3SeqnreN3TdtLT71PldHP3m82+57TbsVfU3gC
48 | OutVYhLPCx4clZlE1pp2k5+D9t2hjF/zkATz7v8v5MaMSMnvZjdwbLSat/qJS498
49 | HFNknYZo4r378FeVHEFJqtBzTGAtlI96cO8RMIiDrBfPIlTUR76X9exlXQKGnhf/
50 | XBV0eDMDd8uGtqtLyYr9Mvhf/1du8Z2/I1NvV6xO94FVkIzxhCtDZ4RgoJKSqMSU
51 | poUSWkuLXJgMfjrKLmu1qcWD097Sgd039B12NZNRsFp/IRYH0Y8N/fFqi3M2DT5Y
52 | bfQMq8891IcTAGZTBTma0uQz0V93zQ3fad2lXNVIj5EZqblAzSUruZtxOIsgwJDK
53 | 8K7lNBRENsooa1SSwl5RmyPmxBqxW0KzCypp5qzhu1o+ro2mXyzTQL0jkkPRu/jE
54 | yD6pJ9p8rxmFWCQ4l9DbRrRTcD1vV3Fo/bmnCLjufFj3jqHk6VWDFgvsxve9pmnB
55 | JFdkhFdgKoau3XSYW3jF8oP+TCG6hlW4q00bNesEb4uixLM5qVPI8ir3Zn2qqaPh
56 | vE2YUkCpvjdemtD6jyVKt6m7D5eM0yuwAQSJy9BCayiE45xmzf6d8bA3tF3MsFp0
57 | mmJmViqOYCqDaPbqSLJ3SulAAz8JpNR7GlpUgouvbcEjTF446UhjY/GMyCOMfDKh
58 | 0onCv20P+QQ3Pyv9THFYJdAOqoBSkh9UuEi75NAWYUTxx+VY2ojZn0HVLhPvT/xg
59 | 9PoGcjILStGxz5gNp3wK5jkS1IvFSlUDN0IZBmgJGDWiv7m2R6fBq3RmRgoeX2GW
60 | GZeg6KssQY979X8/YCO+k6F0thZc2OD65jN5vpGDA1hbsiromVqP3y+hgFQWxeI+
61 | 0QwZFf2J4CKuLkZ5rMmkBR8+/H8bqcGLzPDJsXwKqT3LqHwmWdoZYbmCBmPNvBUf
62 | uUf/4SO6C9An7DlpqO5Iq3I0Hc9SW/nfqH8YLvp4xVWLE7/EYZVJ+n/fla1Rc+M9
63 | BUVlTbIPTP+hSKzHWZfJeaX9gE1QCi5Y7/Xs/scKQbld6/fO8wXL+/mbRhpoQG0s
64 | ttjrFiChLS9+14wJYV1ofhM3RXJAgZh1PJqtSF1/lt5J1mhQXum3Xfifbg09Q8/5
65 | /v+zk0QoXFoHZeIfOcTDuYTPCd60iIHgr91jwF91nWLn+VZNCOg8utZErU42uQ4K
66 | SIkS0NwzqYt/HxthUMXmO3+82z6oix/Ue04bpWd/SUJgZkSnKnHp0VqusGc48Wwh
67 | P+yUvXdBBczKnx9iQ3hhjBSI+zl5Xd19U1wC8uS27wVJ6EJOdtK3yRFF21brrIJi
68 | lD1U9TSzuTyYf1/CK5Amk5jAj/iRexoFAvmA4EOX5dIXgkuJoiQ5Kdhv7pu4HKTh
69 |
--------------------------------------------------------------------------------
/.travis/install-dhall-to-yaml.sh:
--------------------------------------------------------------------------------
1 | #!/bin/bash
2 |
3 | set -eux
4 |
5 | travis_retry() {
6 | cmd=$*
7 | $cmd || (sleep 2 && $cmd) || (sleep 10 && $cmd)
8 | }
9 |
10 | DALL_BIN_URL=https://github.com/dhall-lang/dhall-haskell/releases/download
11 | TAG_VERSION=1.34.0
12 | DHALL_TO_JSON_VERSION=1.7.1
13 |
14 | fetch_dhall-to-yaml_osx() {
15 | curl -sL $DALL_BIN_URL/$TAG_VERSION/dhall-json-$DHALL_TO_JSON_VERSION-x86_64-macos.tar.bz2 |\
16 | tar xjv -C ~/.local/bin --strip-components=1
17 | }
18 |
19 | fetch_dhall-to-yaml_linux() {
20 | curl -sL $DALL_BIN_URL/$TAG_VERSION/dhall-json-$DHALL_TO_JSON_VERSION-x86_64-linux.tar.bz2 |\
21 | tar xjv -C ~/.local/bin --strip-components=2
22 | }
23 |
24 | mkdir -p ~/.local/bin;
25 | if [ "$(uname)" = "Darwin" ]; then
26 | travis_retry fetch_dhall-to-yaml_osx
27 | else
28 | travis_retry fetch_dhall-to-yaml_linux
29 | fi
30 |
31 |
--------------------------------------------------------------------------------
/.travis/install-stack.sh:
--------------------------------------------------------------------------------
1 | #!/bin/bash
2 |
3 | set -eux
4 |
5 | travis_retry() {
6 | cmd=$*
7 | $cmd || (sleep 2 && $cmd) || (sleep 10 && $cmd)
8 | }
9 |
10 | fetch_stack_osx() {
11 | curl -skL https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;
12 | }
13 |
14 | fetch_stack_linux() {
15 | curl -sL https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack';
16 | }
17 |
18 | mkdir -p ~/.local/bin;
19 | if [ "$(uname)" = "Darwin" ]; then
20 | travis_retry fetch_stack_osx
21 | else
22 | travis_retry fetch_stack_linux
23 | fi
24 |
25 | travis_retry stack --no-terminal setup;
26 |
--------------------------------------------------------------------------------
/.travis/requirements.txt:
--------------------------------------------------------------------------------
1 | ghp-import==0.5.5
2 |
--------------------------------------------------------------------------------
/.travis/visualize-test.sh:
--------------------------------------------------------------------------------
1 | #!/bin/bash
2 |
3 | set -eux
4 |
5 | echo 'int main() { return 1 * 2 + 4; }' | stack exec htcc -- /dev/stdin --visualize-ast
6 | echo 'int printf(); void fizzbuzz(int n) { for (int i = 1; i < n; ++i) { if (!(i % 15)) printf("fizzbuzz\n"); else if (!(i % 5)) printf("fizz\n"); else if (!(i % 3)) printf("buzz\n"); else printf("%d\n", i); } } int main() { fizzbuzz(50); }' |\
7 | stack exec htcc -- /dev/stdin \
8 | --visualize-ast \
9 | --img-resolution 1280x720 \
10 | --out fizzbuzz.svg
11 |
12 | if [ ! -f ./out.svg ] || [ ! -f ./fizzbuzz.svg ] ; then exit 1; fi
13 | if [ "640" != "$(identify -format '%w' out.svg)" ]; then exit 1; fi
14 | if [ "480" != "$(identify -format '%h' out.svg)" ]; then exit 1; fi
15 | if [ "1280" != "$(identify -format '%w' fizzbuzz.svg)" ]; then exit 1; fi
16 | if [ "720" != "$(identify -format '%h' fizzbuzz.svg)" ]; then exit 1; fi
17 |
--------------------------------------------------------------------------------
/ChangeLog.md:
--------------------------------------------------------------------------------
1 | # Changelog for htcc
2 |
3 | ## 0.0.0.1
4 |
5 | * Implemented of LL(1) arithmetic expression compilation
6 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright roki (c) since 2019
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Author name here nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 |
htcc
2 |
3 |
4 | :baby_chick: A tiny C language compiler (x86-64) (WIP)
5 |
6 |
7 |
23 |
24 | ## Build
25 |
26 | ```sh
27 | $ stack build
28 | $ stack build --fast # no optimized
29 | ```
30 |
31 | ## Usage
32 |
33 | ```sh
34 | $ stack exec htcc -- -h
35 | Usage: htcc [--visualize-ast] [--img-resolution RESOLUTION] file [-o|--out file]
36 | [-w|--supress-warns]
37 |
38 | Available options:
39 | -h,--help Show this help text
40 | --visualize-ast Visualize an AST built from source code
41 | --img-resolution RESOLUTION
42 | Specify the resolution of the AST graph to be
43 | generated (default: 640x480)
44 | file Specify the input file name
45 | -o,--out file Specify the output destination file name, supported
46 | only svg (default: ./out.svg)
47 | -w,--supress-warns Disable all warning messages
48 | ```
49 |
50 | Simple compilation:
51 |
52 | ```sh
53 | $ echo 'int printf(); int main() { printf("hello world!\n"); }' > t.c
54 | $ stack exec htcc -- t.c > t.s
55 | $ gcc -no-pie t.s -o out
56 | ```
57 |
58 | For one liner:
59 |
60 | ```sh
61 | $ echo 'int printf(); int main() { printf("hello world!\n"); }' | stack exec htcc -- /dev/stdin | gcc -xassembler -no-pie -o out -
62 | ```
63 |
64 | ## AST diagram generation
65 |
66 | htcc has the ability to visualize ASTs built from loaded C code.
67 | This option allows to specify the resolution and output file.
68 | Examples are shown in the following table.
69 |
70 |
71 |
72 | Command |
73 | Output |
74 |
75 |
76 | $ echo 'int main() { return 1 * 2 + 4; }' |\
77 | stack exec htcc -- /dev/stdin --visualize-ast |
78 |  |
79 |
80 |
81 | $ echo 'int printf();
82 | void fizzbuzz(int n) {
83 | for (int i = 1; i < n; ++i) {
84 | if (!(i % 15)) printf("fizzbuzz\n");
85 | else if (!(i % 3)) printf("fizz\n");
86 | else if (!(i % 5)) printf("buzz\n");
87 | else printf("%d\n", i);
88 | }
89 | }
90 | int main() { fizzbuzz(50); }' |\
91 | stack exec htcc -- /dev/stdin\
92 | --visualize-ast\
93 | --img-resolution 1280x720\
94 | --out fizzbuzz.svg |
95 |  |
96 |
97 |
98 |
99 | ## Appearance of operations
100 |
101 |
102 |
103 |
104 |
105 | ## Tests and run examples
106 |
107 | If you want to run outside the Linux environment,
108 | if [docker](https://www.docker.com/)
109 | and [docker-compose](https://github.com/docker/compose) are installed,
110 | you can run tests inside the docker container by specifying docker as an argument.
111 |
112 | ```sh
113 | $ stack test --test-arguments --help
114 | htcc> test (suite: htcc-test, args: --help)
115 | Usage: htcc-test [--clean] COMMAND
116 | The htcc unit tester
117 |
118 | Available options:
119 | -h,--help Show this help text
120 | --clean clean the docker container
121 |
122 | Available commands:
123 | subp run tests with subprocess
124 | docker run tests in docker container
125 | self run the test using htcc's processing power
126 |
127 | htcc> Test suite htcc-test passed
128 | $ stack test --test-arguments self
129 | $ stack test --test-arguments subp
130 | $ stack test --test-arguments docker # For running outside the linux environment. It requires docker and docker-compose.
131 | ```
132 |
133 | If you want to delete the created test container and its image, execute as follows:
134 |
135 | ```sh
136 | $ stack test --test-arguments docker --test-arguments --clean
137 | ```
138 |
139 | Source files that can be compiled by htcc are placed under the [example/](https://github.com/falgon/htcc/tree/master/example).
140 |
141 | ```sh
142 | $ cd example
143 | $ make
144 | ```
145 |
146 | For the same reason, when running in docker ([lifegame](https://github.com/falgon/htcc/blob/master/example/lifegame.c) is not supported because it need to clear standard output):
147 |
148 | ```sh
149 | $ cd example
150 | $ make docker
151 | $ make clean_docker # Stop and delete docker container, and delete image
152 | ```
153 |
154 | ## Benchmark
155 |
156 | ```sh
157 | $ stack bench
158 | ```
159 |
160 | ## Documents
161 |
162 | The implementation description is available in [here](https://falgon.github.io/htcc).
163 |
164 | ## Specification and Requirements
165 |
166 | htcc outputs x86_64 assembly according to System V ABI [[2]](#cite2) and
167 | [GCC 7.4.0](https://gcc.gnu.org/onlinedocs/7.4.0/) is used for assemble.
168 | Perhaps a newer version of GCC will work, but not checked currently.
169 |
170 | ## About emoji of commit messages
171 |
172 | The emoji included in the commit message is used according to [gitmoji](https://gitmoji.carloscuesta.me/).
173 |
174 | ## FAQ
175 |
176 | ### Your compiler is inefficient :)
177 |
178 | I know :confused:
179 |
180 | This is a compiler made for research, not for practical purposes
181 | and the author also developed the compiler for the first time.
182 | If you can suggest improvements, please submit issues or send PRs.
183 | Thanks in advance for all the improvements.
184 |
185 | ### When I try to play with ghci, I get a warning "WARNING:. is owned by someone else, IGNORING!"
186 |
187 | Check your permissions.
188 | The answer on [stack overflow](https://stackoverflow.com/questions/24665531/ghci-haskell-compiler-error-home-user-ghci-is-owned-by-someone-else-ignor) may be useful.
189 |
190 | ## License
191 |
192 | [](https://app.fossa.com/projects/git%2Bgithub.com%2Ffalgon%2Fhtcc?ref=badge_large)
193 |
194 | ## References
195 |
196 |
197 | - JTC1/SC22/WG14. (2011). N1570 Commitee Draft [online]. Available from: PDF, HTML.
198 | - H.J. Lu, Michael Matz, Milind Girkar, Jan Hubicka, Andreas Jaeger and Mark Mitchell. (2018). System V Application Binary Interface AMD64 Architecture Processor Supplement (With LP64 and ILP32 Programming Models) Version 1.0 [online]. Available from: PDF.
199 | - Rui Ueyama. (2019). 低レイヤを知りたい人のためのCコンパイラ作成入門 [online]. Available from: https://www.sigbus.info/compilerbook.
200 | - 前橋和弥. (2009). プログラミング言語を作る. 技術評論社.
201 |
202 |
--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/app/Main.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Main where
3 |
4 | import Control.Conditional (ifM)
5 | import Data.Bool (bool)
6 | import Data.List.Split (splitOn)
7 | import Data.Maybe (isJust, isNothing)
8 | import qualified Data.Text.IO as T
9 | import Data.Tuple.Extra (both, dupe, fst3)
10 | import Diagrams.TwoD.Size (mkSizeSpec2D)
11 | import Options.Applicative
12 | import System.Directory (doesFileExist)
13 | import System.Exit (exitFailure)
14 | import Text.PrettyPrint.ANSI.Leijen (char, linebreak, text,
15 | (<+>))
16 | import Text.Read (readMaybe)
17 |
18 | import Htcc.Asm (InputCCode, casm,
19 | execAST)
20 | import Htcc.Parser (ASTs)
21 | import Htcc.Parser.ConstructionData.Scope.Var (GlobalVars, Literals)
22 | import Htcc.Utils (errTxtDoc, locTxtDoc,
23 | putDocLnErr,
24 | putStrLnErr)
25 | import Htcc.Visualizer (visualize)
26 |
27 | data Options = Options
28 | { visualizeAST :: Bool
29 | , resolution :: String
30 | , inputFName :: FilePath
31 | , outputFName :: FilePath
32 | , supressWarn :: Bool
33 | } deriving Show
34 |
35 | visualizeASTP :: Parser Bool
36 | visualizeASTP = switch $ mconcat
37 | [ long "visualize-ast"
38 | , help "Visualize an AST built from source code"
39 | ]
40 |
41 | resolutionP :: Parser String
42 | resolutionP = strOption $ mconcat
43 | [ metavar "RESOLUTION"
44 | , long "img-resolution"
45 | , help "Specify the resolution of the AST graph to be generated"
46 | , value "640x480"
47 | , showDefaultWith id
48 | ]
49 |
50 | inputFNameP :: Parser FilePath
51 | inputFNameP = strArgument $ mconcat
52 | [ metavar "file"
53 | , action "file"
54 | , help "Specify the input file name"
55 | ]
56 |
57 | outputFNameP :: Parser FilePath
58 | outputFNameP = strOption $ mconcat
59 | [ metavar "file"
60 | , short 'o'
61 | , long "out"
62 | , help "Specify the output destination file name, supported only svg"
63 | , value "./out.svg"
64 | , showDefaultWith id
65 | ]
66 |
67 | supressWarnP :: Parser Bool
68 | supressWarnP = switch $ mconcat
69 | [ short 'w'
70 | , long "supress-warns"
71 | , help "Disable all warning messages"
72 | ]
73 |
74 | optionsP :: Parser Options
75 | optionsP = (<*>) helper $
76 | Options <$> visualizeASTP <*> resolutionP <*> inputFNameP <*> outputFNameP <*> supressWarnP
77 |
78 | parseResolution :: (Num a, Read a) => String -> (Maybe a, Maybe a)
79 | parseResolution xs = let rs = splitOn "x" xs in if length rs /= 2 then dupe Nothing else
80 | let rs' = map readMaybe rs in if any isNothing rs' then dupe Nothing else (head rs', rs' !! 1)
81 |
82 | execVisualize :: Show i => Options -> ASTs i -> IO ()
83 | execVisualize ops ast = let rlt = parseResolution $ resolution ops in do
84 | rs <- if uncurry (&&) (both isJust rlt) then return rlt else
85 | (Just 640, Just 480) <$ putStrLnErr "warning: the specified resolution is invalid, so using default resolution."
86 | visualize ast (uncurry mkSizeSpec2D rs) (outputFName ops)
87 |
88 | main :: IO ()
89 | main = do
90 | ops <- execParser $ info optionsP fullDesc
91 | ifM (not <$> doesFileExist (inputFName ops)) (notFould (inputFName ops) >> exitFailure) $
92 | T.readFile (inputFName ops) >>= execAST' (supressWarn ops) (inputFName ops) >>= maybe (return ()) (bool casm (execVisualize ops . fst3) (visualizeAST ops))
93 | where
94 | execAST' :: Bool -> FilePath -> InputCCode -> IO (Maybe (ASTs Integer, GlobalVars Integer, Literals Integer))
95 | execAST' = execAST
96 | notFould fpath = putDocLnErr $
97 | locTxtDoc "htcc:" <+>
98 | errTxtDoc "error:" <+>
99 | text fpath <> char ':' <+>
100 | text "no such file" <> linebreak <>
101 | text "compilation terminated."
102 |
--------------------------------------------------------------------------------
/assets/example_ast/calc.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/falgon/htcc/163a88588ecb75c53e8e5f60bc321bb43a4bb193/assets/example_ast/calc.png
--------------------------------------------------------------------------------
/assets/example_ast/fizzbuzz.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/falgon/htcc/163a88588ecb75c53e8e5f60bc321bb43a4bb193/assets/example_ast/fizzbuzz.png
--------------------------------------------------------------------------------
/assets/some_operation.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/falgon/htcc/163a88588ecb75c53e8e5f60bc321bb43a4bb193/assets/some_operation.gif
--------------------------------------------------------------------------------
/bench/Criterion.hs:
--------------------------------------------------------------------------------
1 | module Main (main) where
2 |
3 | import Criterion.Main (bench, bgroup, defaultConfig, defaultMainWith,
4 | nf, whnf)
5 | import Criterion.Types (reportFile)
6 |
7 | import Data.Either (fromRight)
8 | import qualified Data.Text as T
9 |
10 | import Htcc.Parser (parse)
11 | import qualified Htcc.Tokenizer as HT
12 | import Htcc.Utils (tshow)
13 |
14 | tknize :: T.Text -> Either (HT.TokenLCNums Int, T.Text) [HT.TokenLC Int]
15 | tknize = HT.tokenize
16 |
17 | data CCodes =
18 | ReturningZero
19 | | StrLiteral
20 | | CalculateFibonacci
21 |
22 | instance Show CCodes where
23 | show ReturningZero = "int main() { retunr 0; }"
24 | show StrLiteral = "int main() { \"\\a\\bhoge\\\\hoge\"; }"
25 | show CalculateFibonacci = "int fib(int n) {\
26 | \ if (n == 0) return 1;\
27 | \ else if (n == 1) return 1;\
28 | \ else if (n >= 2) return fib(n - 1) + fib(n - 2);\
29 | \ else return 0;\
30 | \}\
31 | \int main() { return fib(5); }"
32 |
33 | main :: IO ()
34 | main = defaultMainWith (defaultConfig { reportFile = Just "./bench_report.html" })
35 | [ bgroup "tokenize programs (whnf)"
36 | [ bench "Returning zero" $ whnf tknize $ tshow ReturningZero
37 | , bench "StrLiteral" $ whnf tknize $ tshow StrLiteral
38 | , bench "Calculate fibonacci" $ whnf tknize $ tshow CalculateFibonacci
39 | ]
40 | , bgroup "tokenize programs (nf)"
41 | [ bench "Returning zero" $ nf tknize $ tshow ReturningZero
42 | , bench "StrLiteral" $ nf tknize $ tshow StrLiteral
43 | , bench "Calculate fibonacci" $ nf tknize $ tshow CalculateFibonacci
44 | ]
45 | , bgroup "parse tokens (whnf)"
46 | [ bench "ReturningZero" $ whnf parse $ fromRight [] $ tknize $ tshow ReturningZero
47 | , bench "StrLiteral" $ whnf parse $ fromRight [] $ tknize $ tshow StrLiteral
48 | , bench "Calculate fibonacci" $ whnf parse $ fromRight [] $ tknize $ tshow CalculateFibonacci
49 | ]
50 | ]
51 |
--------------------------------------------------------------------------------
/docker/Dockerfile:
--------------------------------------------------------------------------------
1 | FROM ubuntu:18.04
2 | ARG term=xterm
3 |
4 | LABEL maintainer="falgon53@yahoo.co.jp"
5 | SHELL ["/bin/bash", "-c"]
6 | ENV DEBCONF_NOWARNINGS yes
7 | ENV TERM $term
8 |
9 | # User setting
10 | ARG user=htcc_user
11 | ARG group=user
12 |
13 | # Install required packages
14 | RUN apt-get -qq update && apt-get install -qq -y --no-install-recommends \
15 | apt-utils \
16 | binutils \
17 | gcc \
18 | gdb \
19 | git \
20 | libc6-dev \
21 | && apt-get clean\
22 | && rm -rf /var/lib/apt/lists/*
23 |
--------------------------------------------------------------------------------
/docker/example.dhall:
--------------------------------------------------------------------------------
1 | let types =
2 | https://raw.githubusercontent.com/falgon/dhall-docker-compose/master/compose/v3/types.dhall
3 |
4 | let defaults =
5 | https://raw.githubusercontent.com/falgon/dhall-docker-compose/master/compose/v3/defaults.dhall
6 |
7 | let htccService =
8 | defaults.Service
9 | ⫽ { image = Some "roki/htcc_example:1.0.0"
10 | , command = Some
11 | ( types.StringOrList.String
12 | "/bin/sh -c 'gcc -no-pie -o spec /htcc_work/spec.s && ./spec'"
13 | )
14 | , volumes = Some [ "/tmp/htcc:/htcc_work" ]
15 | , build = Some
16 | ( types.Build.Object
17 | { context = "."
18 | , dockerfile = "../docker/Dockerfile"
19 | , args =
20 | types.ListOrDict.List
21 | ([] : List (Optional types.StringOrNumber))
22 | }
23 | )
24 | }
25 |
26 | let services
27 | : types.Services
28 | = [ { mapKey = "htcc", mapValue = htccService } ]
29 |
30 | in defaults.ComposeConfig ⫽ { services = Some services } : types.ComposeConfig
31 |
--------------------------------------------------------------------------------
/docker/test.dhall:
--------------------------------------------------------------------------------
1 | let types =
2 | https://raw.githubusercontent.com/falgon/dhall-docker-compose/master/compose/v3/types.dhall
3 |
4 | let defaults =
5 | https://raw.githubusercontent.com/falgon/dhall-docker-compose/master/compose/v3/defaults.dhall
6 |
7 | let htccService =
8 | defaults.Service
9 | ⫽ { image = Some "roki/htcc_test:1.0.0"
10 | , command = Some
11 | ( types.StringOrList.String
12 | "/bin/sh -c 'gcc -no-pie -o spec /htcc_work/spec.s && ./spec'"
13 | )
14 | , volumes = Some [ "/tmp/htcc:/htcc_work" ]
15 | , build = Some
16 | ( types.Build.Object
17 | { context = "."
18 | , dockerfile = "./docker/Dockerfile"
19 | , args =
20 | types.ListOrDict.List
21 | ([] : List (Optional types.StringOrNumber))
22 | }
23 | )
24 | }
25 |
26 | let services
27 | : types.Services
28 | = [ { mapKey = "htcc", mapValue = htccService } ]
29 |
30 | in defaults.ComposeConfig ⫽ { services = Some services } : types.ComposeConfig
31 |
--------------------------------------------------------------------------------
/example/Makefile:
--------------------------------------------------------------------------------
1 | SHELL=/bin/bash
2 | DIST_DIR=dist
3 |
4 | define compile
5 | mkdir -p $(DIST_DIR)
6 | stack exec htcc -- $1 | gcc -xassembler -no-pie -o $(DIST_DIR)/$2 -
7 | endef
8 |
9 | define compile_docker_and_run
10 | mkdir -p /tmp/htcc
11 | stack exec htcc -- $1 > /tmp/htcc/spec.s
12 | dhall-to-yaml < ../docker/example.dhall | docker-compose -f - up
13 | rm -r /tmp/htcc
14 | endef
15 |
16 | all: knapsack shuffle_and_sort merge_sort_linked_list lifegame
17 |
18 | knapsack:
19 | @$(call compile,"./knapsack.c","knapsack")
20 |
21 | shuffle_and_sort:
22 | @$(call compile,"./shuffle_and_sort.c","shuffle_and_sort")
23 |
24 | merge_sort_linked_list:
25 | @$(call compile,"./merge_sorting_linked_list.c","merge_sorting_linked_list")
26 |
27 | lifegame:
28 | @$(call compile,"./lifegame.c","lifegame")
29 |
30 | docker: docker_knapsack docker_shuffle_and_sort docker_merge_sort_linked_list
31 |
32 | docker_knapsack:
33 | @$(call compile_docker_and_run,"./knapsack.c")
34 |
35 | docker_shuffle_and_sort:
36 | @$(call compile_docker_and_run,"./shuffle_and_sort.c")
37 |
38 | docker_merge_sort_linked_list:
39 | @$(call compile_docker_and_run,"./merge_sorting_linked_list.c")
40 |
41 | clean:
42 | $(RM) -r $(DIST_DIR)
43 |
44 | clean_docker:
45 | dhall-to-yaml < ../docker/example.dhall | docker-compose -f - down --rmi all
46 |
47 | .PHONY: knapsack shuffle_and_sort merge_sort_linked_list lifegame docker_knapsack docker_shuffle_and_sort docker_merge_sort_linked_list docker clean
48 |
--------------------------------------------------------------------------------
/example/knapsack.c:
--------------------------------------------------------------------------------
1 | /*
2 | *
3 | * Given @n@ items and their respective volume @ct@ and value @vals@ for a knapsack of capacity C,
4 | * calculate the maximum sum of the values of the items in
5 | * the knapsack so as not to exceed knapsack capacity @capacity@ (See also: https://en.wikipedia.org/wiki/Knapsack_problem).
6 | * A knapsack can only contain one item of the same type (\(x_i\in\left\{0,1\right\}\).
7 | *
8 | */
9 |
10 | typedef long time_t;
11 |
12 | int printf();
13 | void* calloc(int, int);
14 | void free(void*);
15 | void srand(int);
16 | int rand(void);
17 | time_t time(time_t*);
18 |
19 | int max(int a, int b) { return a > b ? a : b; }
20 |
21 | // Solving with DP
22 | int knapsack(int capacity, int* ct, int* vals, int n)
23 | {
24 | int** tr = calloc(n + 1, sizeof(int*));
25 | for (int i = 0; i < n + 1; ++i) tr[i] = calloc(capacity + 1, sizeof(int));
26 |
27 | for (int i = 0; i <= n; ++i) {
28 | for (int j = 0; j <= capacity; ++j) {
29 | if (!i || !j) tr[i][j] = 0;
30 | else if (ct[i - 1] <= j) tr[i][j] = max(vals[i - 1] + tr[i - 1][j - ct[i - 1]], tr[i - 1][j]);
31 | else tr[i][j] = tr[i - 1][j];
32 | }
33 | }
34 |
35 | int result = tr[n][capacity];
36 |
37 | for (int i = 0; i < n + 1; ++i) {
38 | free(tr[i]);
39 | tr[i] = 0;
40 | }
41 | free(tr);
42 | tr = 0;
43 |
44 | return result;
45 | }
46 |
47 | int* rand_ints(int size, int min, int max)
48 | {
49 | int* rs = calloc(size, sizeof(int));
50 | for (int i = 0; i < size; ++i) rs[i] = rand() % max + min;
51 | return rs;
52 | }
53 |
54 | void print(int* first, int* last)
55 | {
56 | for (; first < last; ++first) printf("%d ", *first);
57 | printf("\n");
58 | }
59 |
60 | int main()
61 | {
62 | srand(time(0));
63 | int item_size = rand() % 15 + 4;
64 |
65 | printf("item size: %d\n", item_size);
66 |
67 | int* vals = rand_ints(item_size, 50, 200);
68 | int* capacities = rand_ints(item_size, 10, 30);
69 | int capacity = rand() % 100 + 50;
70 |
71 | printf("value of items: ");
72 | print(vals, vals + item_size);
73 |
74 | printf("capacity of items: ");
75 | print(capacities, capacities + item_size);
76 |
77 | printf("capacity: %d\n", capacity);
78 |
79 | printf("retult: %d\n", knapsack(capacity, capacities, vals, item_size));
80 |
81 | free(vals);
82 | free(capacities);
83 |
84 | return 0;
85 | }
86 |
--------------------------------------------------------------------------------
/example/lifegame.c:
--------------------------------------------------------------------------------
1 | /*
2 | *
3 | * The simulator of Conway's Game of Life (See also: https://en.wikipedia.org/wiki/Conway%27s_Game_of_Life)
4 | * Rules:
5 | * 1. The cell has one life or not. In this, cells with life are '@', and cells without life are space.
6 | * There are eight neighbors, including diagonally.
7 | * 2. Each life will survive in the next generation if the number of lives in adjacent cells is 2 or 3.
8 | * Otherwise it will die.
9 | * 3. A cell without life will be born in the next generation if the number of lives in adjacent cells is 3.
10 | *
11 | */
12 |
13 | typedef long time_t;
14 |
15 | void srand(int);
16 | int rand(void);
17 | time_t time(time_t);
18 | void sleep(int);
19 | void* calloc(int, int);
20 | void free(void*);
21 | int printf();
22 | int system(char*);
23 |
24 | _Bool*** init_map(int n)
25 | {
26 | _Bool*** map = calloc(2, sizeof(_Bool***));
27 | for (int i = 0; i < 2; ++i) {
28 | map[i] = calloc(n + 2, sizeof(_Bool*));
29 | for (int j = 0; j < n + 2; ++j) {
30 | map [i][j] = calloc(n + 2, sizeof(_Bool));
31 | }
32 | }
33 |
34 | srand(time(0));
35 |
36 | for (int i = 1; i <= n; ++i)
37 | for (int j = 1; j <= n; ++j)
38 | map[0][i][j] = rand() % 2;
39 |
40 | return map;
41 | }
42 |
43 | void free_map(_Bool*** map, int n)
44 | {
45 | for (int i = 0; i < 2; ++i) {
46 | for (int j = 0; j < n + 2; ++j) {
47 | free(map[i][j]);
48 | map[i][j] = 0;
49 | }
50 | free(map[i]);
51 | map[i] = 0;
52 | }
53 | free(map);
54 | map = 0;
55 | }
56 |
57 | void lifegame(_Bool*** m, int cell_size)
58 | {
59 | int st = 0;
60 | for (int g = 0;; ++g) {
61 | system("clear");
62 | printf("Generation: %d\n", g);
63 | for (int i = 1; i <= cell_size; ++i) {
64 | for (int j = 1; j <= cell_size; ++j)
65 | printf("%c", m[st][i][j] ? '@' : ' ');
66 | printf("\n");
67 | }
68 | printf("\n");
69 | sleep(1);
70 |
71 | int t = 0;
72 | for (int i = 1; i <= cell_size; ++i) {
73 | for (int j = 1; j <= cell_size; ++j) {
74 | t = m[st][i + 1 > cell_size ? 1 : i + 1][j] +
75 | m[st][i - 1 ?: cell_size][j] +
76 | m[st][i][j + 1 > cell_size ? 1 : j + 1] +
77 | m[st][i][j - 1 ?: cell_size] +
78 | m[st][i + 1 > cell_size ? 1 : i + 1][j + 1 > cell_size ? 1 : j + 1] +
79 | m[st][i + 1 > cell_size ? 1 : i + 1][j - 1 ?: cell_size] +
80 | m[st][i - 1 ?: cell_size][j + 1 > cell_size ? 1 : j + 1] +
81 | m[st][i - 1 ?: cell_size][j - 1 ?: cell_size];
82 | m[st ^ 1][i][j] = m[st][i][j] ? t == 2 || t == 3 : t == 3;
83 | }
84 | }
85 | st ^= 1;
86 | }
87 | }
88 |
89 | int main()
90 | {
91 | int n = 30;
92 | _Bool*** m = init_map(n);
93 | lifegame(m, n);
94 | free_map(m, n);
95 | }
96 |
--------------------------------------------------------------------------------
/example/merge_sorting_linked_list.c:
--------------------------------------------------------------------------------
1 | /*
2 | *
3 | *
4 | * Perform merge sort on linked list and sort in ascending order.
5 | *
6 | *
7 | */
8 |
9 | typedef long time_t;
10 |
11 | time_t time(time_t);
12 | void srand(int);
13 | int rand();
14 | void* calloc(int, int);
15 | void free(void*);
16 | int printf();
17 |
18 | struct node_type {
19 | int val;
20 | struct node_type* next;
21 | };
22 |
23 | typedef struct node_type node;
24 |
25 | void split(node* src, node** front, node** back)
26 | {
27 | node* slow = *front = src;
28 |
29 | for (node* fast = src->next; fast;) {
30 | if (fast = fast->next) {
31 | slow = slow->next;
32 | fast = fast->next;
33 | }
34 | }
35 | *back = slow->next;
36 | slow->next = 0;
37 | }
38 |
39 | node* merge(node* lhs, node* rhs)
40 | {
41 | node* result = 0;
42 | if (!lhs) return rhs;
43 | else if (!rhs) return lhs;
44 |
45 | if (lhs->val <= rhs->val) {
46 | result = lhs;
47 | result->next = merge(lhs->next, rhs);
48 | } else {
49 | result = rhs;
50 | result->next = merge(lhs, rhs->next);
51 | }
52 | return result;
53 | }
54 |
55 | void merge_sort(node** head_ref)
56 | {
57 | node* head = *head_ref;
58 |
59 | if (!head || !head->next) return;
60 |
61 | node* lhs = 0;
62 | node* rhs = 0;
63 | split(head, &lhs, &rhs);
64 | merge_sort(&lhs);
65 | merge_sort(&rhs);
66 | *head_ref = merge(lhs, rhs);
67 | }
68 |
69 | void push(node** head_ref, int val)
70 | {
71 | node* n = calloc(1, sizeof(node));
72 | n->val = val;
73 | n->next = *head_ref;
74 | *head_ref = n;
75 | }
76 |
77 | void print(node* n)
78 | {
79 | for (; n; n = n->next) printf("%d ", n->val);
80 | printf("\n");
81 | }
82 |
83 | void free_list(node* n)
84 | {
85 | for (node* t; n; n = t) {
86 | t = n->next;
87 | free(n);
88 | n = 0;
89 | }
90 | }
91 |
92 | node* rand_list(int s, int min, int max)
93 | {
94 | srand(time(0));
95 | node* list = 0;
96 | for (int i = 0; i < s; ++i) push(&list, rand() % max + min);
97 | return list;
98 | }
99 |
100 | int main()
101 | {
102 | int n = 10;
103 | node* list = rand_list(n, 1, 10);
104 | printf("Before sorting: ");
105 | print(list);
106 |
107 | merge_sort(&list);
108 |
109 | printf("After sotring: ");
110 | print(list);
111 |
112 | free_list(list);
113 |
114 | return 0;
115 | }
116 |
--------------------------------------------------------------------------------
/example/shuffle_and_sort.c:
--------------------------------------------------------------------------------
1 | /*
2 | *
3 | * After shuffling several sequences with the Fishers shuffle algorithm,
4 | * sort them in ascending order with quick sort.
5 | *
6 | */
7 |
8 | typedef long time_t;
9 |
10 | void srand(unsigned);
11 | int rand(void);
12 | time_t time(time_t*);
13 | int printf();
14 |
15 | void swap(int* a, int* b)
16 | {
17 | if (a == b) return;
18 | *a ^= *b, *b ^= *a, *a ^= *b;
19 | }
20 |
21 | void shuffle(int* first, int* last)
22 | {
23 | if (first == last) return;
24 | int distance = last - first;
25 | srand(time(0));
26 | for (--last, --distance; first < last; ++first, --distance)
27 | swap(first, first + rand() % distance + 1);
28 | }
29 |
30 | void iota(int* first, int* last, int val)
31 | {
32 | for (; first < last; ++first, ++val) *first = val;
33 | }
34 |
35 | void print(int* first, int* last)
36 | {
37 | for (; first < last; ++first) printf("%d ", *first);
38 | printf("\n");
39 | }
40 |
41 | int* max(int* a, int* b)
42 | {
43 | return *a < *b ? b : a;
44 | }
45 |
46 | int* min(int* a, int* b)
47 | {
48 | return max(a, b) == a ? b : a;
49 | }
50 |
51 | int* med3(int* a, int* b, int* c)
52 | {
53 | return max(min(a, b), min(max(a, b), c));
54 | }
55 |
56 | int quick_sort(int* first, int* last)
57 | {
58 | if (first == last) return;
59 | swap(first, med3(first, first + ((last - first) >> 1), last));
60 |
61 | int* l = first;
62 | int* r = last - 1;
63 |
64 | while (l < r) {
65 | for (; *r > *first; --r);
66 | for (; *l <= *first && l < r; ++l);
67 | swap(l, r);
68 | }
69 | swap(first, l);
70 | quick_sort(first, l);
71 | quick_sort(l + 1, last);
72 | }
73 |
74 | int main()
75 | {
76 | int ar[10];
77 | int size = sizeof ar / sizeof *ar;
78 |
79 | iota(ar, ar + size);
80 | shuffle(ar, ar + size);
81 |
82 | printf("Before sorting: ");
83 | print(ar, ar + size);
84 |
85 | quick_sort(ar, ar + size);
86 |
87 | printf("After sorting: ");
88 | print(ar, ar + size);
89 |
90 | return 0;
91 | }
92 |
--------------------------------------------------------------------------------
/htcc.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 1.12
2 |
3 | -- This file has been generated from package.yaml by hpack version 0.33.0.
4 | --
5 | -- see: https://github.com/sol/hpack
6 | --
7 | -- hash: 22bacaccc5bc8617817eb1c982386f1b7ce9a77e1928a9f47181e1dcd7a27d2a
8 |
9 | name: htcc
10 | version: 0.0.0.1
11 | synopsis: The full scratch implementation of tiny C compiler (x86_64)
12 | description: The full scratch implementation of tiny C compiler (x86_64).
13 | This compiler outputs x86_64 assembly code from "general" C code.
14 | .
15 | It consists of:
16 | .
17 | * the lexical analyzer
18 | * the parser that performs parsing with recursive descent and construction of abstract syntax trees (ASTs)
19 | * the method that outputs x86_64 assembly code from ASTs
20 | .
21 | __This compiler is not practical purposes__, but focuses on implementation experiments.
22 | .
23 | For more information, please see the README on GitHub at .
24 | category: Compiler
25 | homepage: https://github.com/falgon/htcc#readme
26 | bug-reports: https://github.com/falgon/htcc/issues
27 | author: roki
28 | maintainer: falgon53@yahoo.co.jp
29 | copyright: 2019 roki
30 | license: MIT
31 | license-file: LICENSE
32 | build-type: Simple
33 | extra-source-files:
34 | README.md
35 | ChangeLog.md
36 |
37 | source-repository head
38 | type: git
39 | location: https://github.com/falgon/htcc
40 |
41 | library
42 | exposed-modules:
43 | Htcc.Asm
44 | Htcc.Asm.Generate
45 | Htcc.Asm.Generate.Core
46 | Htcc.Asm.Intrinsic
47 | Htcc.Asm.Intrinsic.Operand
48 | Htcc.Asm.Intrinsic.Register
49 | Htcc.Asm.Intrinsic.Structure
50 | Htcc.Asm.Intrinsic.Structure.Internal
51 | Htcc.Asm.Intrinsic.Structure.Section.Data
52 | Htcc.Asm.Intrinsic.Structure.Section.Text
53 | Htcc.Asm.Intrinsic.Structure.Section.Text.Directive
54 | Htcc.Asm.Intrinsic.Structure.Section.Text.Instruction
55 | Htcc.Asm.Intrinsic.Structure.Section.Text.Operations
56 | Htcc.CRules
57 | Htcc.CRules.Char
58 | Htcc.CRules.LexicalElements
59 | Htcc.CRules.Preprocessor
60 | Htcc.CRules.Preprocessor.Core
61 | Htcc.CRules.Preprocessor.Punctuators
62 | Htcc.CRules.Types
63 | Htcc.CRules.Types.CType
64 | Htcc.CRules.Types.StorageClass
65 | Htcc.CRules.Types.TypeKind
66 | Htcc.Parser
67 | Htcc.Parser.AST
68 | Htcc.Parser.AST.Core
69 | Htcc.Parser.AST.DeduceKind
70 | Htcc.Parser.AST.Type
71 | Htcc.Parser.AST.Var
72 | Htcc.Parser.AST.Var.Init
73 | Htcc.Parser.ConstructionData
74 | Htcc.Parser.ConstructionData.Core
75 | Htcc.Parser.ConstructionData.Scope
76 | Htcc.Parser.ConstructionData.Scope.Enumerator
77 | Htcc.Parser.ConstructionData.Scope.Function
78 | Htcc.Parser.ConstructionData.Scope.ManagedScope
79 | Htcc.Parser.ConstructionData.Scope.Tag
80 | Htcc.Parser.ConstructionData.Scope.Typedef
81 | Htcc.Parser.ConstructionData.Scope.Utils
82 | Htcc.Parser.ConstructionData.Scope.Var
83 | Htcc.Parser.Parsing
84 | Htcc.Parser.Parsing.Core
85 | Htcc.Parser.Parsing.Global
86 | Htcc.Parser.Parsing.Global.Function
87 | Htcc.Parser.Parsing.Global.Var
88 | Htcc.Parser.Parsing.StmtExpr
89 | Htcc.Parser.Parsing.Type
90 | Htcc.Parser.Parsing.Typedef
91 | Htcc.Parser.Utils
92 | Htcc.Parser.Utils.Core
93 | Htcc.Tokenizer
94 | Htcc.Tokenizer.Core
95 | Htcc.Tokenizer.Token
96 | Htcc.Utils
97 | Htcc.Utils.Bool
98 | Htcc.Utils.CompilationState
99 | Htcc.Utils.List
100 | Htcc.Utils.NaturalTransformations
101 | Htcc.Utils.Print
102 | Htcc.Utils.Text
103 | Htcc.Utils.Tuple
104 | Htcc.Visualizer
105 | Htcc.Visualizer.Core
106 | other-modules:
107 | Paths_htcc
108 | hs-source-dirs:
109 | src
110 | build-depends:
111 | ansi-wl-pprint
112 | , base >=4.7 && <5
113 | , bytestring
114 | , cond
115 | , containers
116 | , deepseq
117 | , diagrams-contrib
118 | , diagrams-lib
119 | , diagrams-svg
120 | , extra
121 | , monad-finally
122 | , monad-loops
123 | , mono-traversable
124 | , mtl
125 | , natural-transformation
126 | , optparse-applicative
127 | , safe
128 | , split
129 | , text
130 | , transformers
131 | default-language: Haskell2010
132 |
133 | executable htcc
134 | main-is: Main.hs
135 | other-modules:
136 | Paths_htcc
137 | hs-source-dirs:
138 | app
139 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror -O2
140 | build-depends:
141 | ansi-wl-pprint
142 | , base >=4.7 && <5
143 | , bytestring
144 | , cond
145 | , containers
146 | , deepseq
147 | , diagrams-contrib
148 | , diagrams-lib
149 | , diagrams-svg
150 | , directory
151 | , extra
152 | , htcc
153 | , monad-finally
154 | , monad-loops
155 | , mono-traversable
156 | , mtl
157 | , natural-transformation
158 | , optparse-applicative
159 | , safe
160 | , split
161 | , text
162 | , transformers
163 | default-language: Haskell2010
164 |
165 | test-suite htcc-test
166 | type: exitcode-stdio-1.0
167 | main-is: Spec.hs
168 | other-modules:
169 | Tests.SubProcTests
170 | Tests.Test1
171 | Tests.Test2
172 | Tests.Test3
173 | Tests.Utils
174 | Paths_htcc
175 | hs-source-dirs:
176 | test
177 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O2
178 | build-depends:
179 | HUnit
180 | , ansi-wl-pprint
181 | , base >=4.7 && <5
182 | , bytestring
183 | , cond
184 | , containers
185 | , deepseq
186 | , dhall-json
187 | , dhall-yaml
188 | , diagrams-contrib
189 | , diagrams-lib
190 | , diagrams-svg
191 | , directory
192 | , extra
193 | , filepath
194 | , foldl
195 | , hspec
196 | , hspec-contrib
197 | , hspec-core
198 | , htcc
199 | , monad-finally
200 | , monad-loops
201 | , mono-traversable
202 | , mtl
203 | , natural-transformation
204 | , optparse-applicative
205 | , process
206 | , safe
207 | , split
208 | , text
209 | , time
210 | , transformers
211 | , turtle
212 | , utf8-string
213 | default-language: Haskell2010
214 |
215 | benchmark criterion
216 | type: exitcode-stdio-1.0
217 | main-is: bench/Criterion.hs
218 | other-modules:
219 | Paths_htcc
220 | ghc-options: -O2
221 | build-depends:
222 | ansi-wl-pprint
223 | , base >=4.7 && <5
224 | , bytestring
225 | , cond
226 | , containers
227 | , criterion
228 | , deepseq
229 | , diagrams-contrib
230 | , diagrams-lib
231 | , diagrams-svg
232 | , extra
233 | , htcc
234 | , monad-finally
235 | , monad-loops
236 | , mono-traversable
237 | , mtl
238 | , natural-transformation
239 | , optparse-applicative
240 | , safe
241 | , split
242 | , text
243 | , transformers
244 | default-language: Haskell2010
245 |
--------------------------------------------------------------------------------
/package.yaml:
--------------------------------------------------------------------------------
1 | name: htcc
2 | version: 0.0.0.1
3 | synopsis: The full scratch implementation of tiny C compiler (x86_64)
4 | description: |
5 | The full scratch implementation of tiny C compiler (x86_64).
6 | This compiler outputs x86_64 assembly code from "general" C code.
7 | .
8 | It consists of:
9 | .
10 | * the lexical analyzer
11 | * the parser that performs parsing with recursive descent and construction of abstract syntax trees (ASTs)
12 | * the method that outputs x86_64 assembly code from ASTs
13 | .
14 | __This compiler is not practical purposes__, but focuses on implementation experiments.
15 | .
16 | For more information, please see the README on GitHub at .
17 | category: Compiler
18 | github: "falgon/htcc"
19 | license: MIT
20 | author: "roki"
21 | maintainer: "falgon53@yahoo.co.jp"
22 | copyright: "2019 roki"
23 |
24 | extra-source-files:
25 | - README.md
26 | - ChangeLog.md
27 |
28 | dependencies:
29 | - base >= 4.7 && < 5
30 | - ansi-wl-pprint
31 | - cond
32 | - extra
33 | - text
34 | - split
35 | - monad-loops
36 | - containers
37 | - bytestring
38 | - deepseq
39 | - safe
40 | - mtl
41 | - monad-finally
42 | - mono-traversable
43 | - transformers
44 | - diagrams-svg
45 | - diagrams-contrib
46 | - diagrams-lib
47 | - natural-transformation
48 | - optparse-applicative
49 |
50 | library:
51 | source-dirs: src
52 |
53 | executables:
54 | htcc:
55 | main: Main.hs
56 | source-dirs: app
57 | ghc-options:
58 | - -threaded
59 | - -rtsopts
60 | - -with-rtsopts=-N
61 | - -Wall
62 | - -Werror
63 | - -O2
64 | dependencies:
65 | - htcc
66 | - directory
67 |
68 | tests:
69 | htcc-test:
70 | main: Spec.hs
71 | source-dirs: test
72 | ghc-options:
73 | - -threaded
74 | - -rtsopts
75 | - -with-rtsopts=-N
76 | - -Wall
77 | - -O2
78 | dependencies:
79 | - htcc
80 | - HUnit
81 | - turtle
82 | - text
83 | - directory
84 | - time
85 | - foldl
86 | - hspec
87 | - hspec-core
88 | - hspec-contrib
89 | - filepath
90 | - dhall-json
91 | - dhall-yaml
92 | - process
93 | - utf8-string
94 |
95 | benchmarks:
96 | criterion:
97 | main: bench/Criterion.hs
98 | ghc-options:
99 | - -O2
100 | dependencies:
101 | - criterion
102 | - htcc
103 |
--------------------------------------------------------------------------------
/src/Htcc/Asm.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Asm
3 | Description : The modules of C Rules
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The executable module for compilation
11 | -}
12 | module Htcc.Asm (
13 | -- * Export modules
14 | module Htcc.Asm.Generate,
15 | casm
16 | ) where
17 |
18 | import Data.Tuple.Extra (uncurry3)
19 |
20 | import Htcc.Asm.Generate
21 | import qualified Htcc.Asm.Intrinsic.Operand as O
22 | import qualified Htcc.Asm.Intrinsic.Structure.Internal as SI
23 | import qualified Htcc.Asm.Intrinsic.Structure.Section.Text.Instruction as TI
24 | import Htcc.Parser (ASTs)
25 | import Htcc.Parser.ConstructionData.Scope.Var (GlobalVars,
26 | Literals)
27 |
28 | -- | Generate full assembly code from string of C source code
29 | casm :: (O.IsOperand i, TI.UnaryInstruction i, TI.BinaryInstruction i, Integral i) => (ASTs i, GlobalVars i, Literals i) -> IO ()
30 | casm = SI.runAsm . uncurry3 casm'
31 |
--------------------------------------------------------------------------------
/src/Htcc/Asm/Generate.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Asm.Generate
3 | Description : The modules of intrinsic (x86_64) assembly
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The executable module for compilation
11 | -}
12 | {-# LANGUAGE OverloadedStrings #-}
13 | module Htcc.Asm.Generate (
14 | InputCCode,
15 | -- * Generator
16 | casm',
17 | buildAST,
18 | execAST
19 | ) where
20 |
21 | import Control.Monad (unless, (>=>))
22 | import Data.Bits (Bits)
23 | import Data.Foldable (toList)
24 | import qualified Data.Sequence as S
25 | import qualified Data.Text as T
26 | import System.Exit (exitFailure)
27 | import Text.PrettyPrint.ANSI.Leijen (Doc, blue,
28 | bold, char,
29 | empty,
30 | magenta, red,
31 | text, (<+>))
32 |
33 | import Htcc.Parser (ASTResult,
34 | ASTs, parse)
35 | import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError)
36 | import Htcc.Parser.ConstructionData.Scope.Var (GlobalVars,
37 | Literals)
38 | import qualified Htcc.Tokenizer as HT
39 |
40 | import Htcc.Asm.Generate.Core
41 | import Htcc.Asm.Intrinsic.Operand
42 | import qualified Htcc.Asm.Intrinsic.Structure as SI
43 | import qualified Htcc.Asm.Intrinsic.Structure.Section.Text as IT
44 |
45 | import Htcc.Utils (dropFst4,
46 | putDocErr,
47 | putDocLnErr,
48 | putStrErr,
49 | putStrLnErr,
50 | toInts, tshow)
51 |
52 | -- | input string, C source code
53 | type InputCCode = T.Text
54 |
55 | data MessageType = ErrorMessage | WarningMessage
56 | deriving (Eq, Ord, Enum, Bounded)
57 |
58 | instance Show MessageType where
59 | show ErrorMessage = "error"
60 | show WarningMessage = "warning"
61 |
62 | {-# INLINE messageColor #-}
63 | messageColor :: MessageType -> Doc -> Doc
64 | messageColor ErrorMessage = red
65 | messageColor WarningMessage = magenta
66 |
67 | {-# INLINE repSpace #-}
68 | repSpace :: Integral i => i -> MessageType -> IO ()
69 | repSpace i mest = do
70 | mapM_ (putStrErr . T.pack . flip replicate ' ' . pred) $ toInts i
71 | putDocErr $ messageColor mest $ char '^'
72 |
73 | {-# INLINE format #-}
74 | format :: T.Text -> Int -> InputCCode -> IO ()
75 | format errMesPre e xs = do
76 | putDocErr $ blue (text $ T.unpack errMesPre) <+> blue (char '|') <+> empty
77 | putStrLnErr (T.lines xs !! max 0 (fromIntegral e))
78 | putStrErr $ T.replicate (T.length errMesPre) " "
79 | putDocErr $ empty <+> blue (char '|') <+> empty
80 |
81 | parsedMessage :: (Integral i, Show i) => MessageType -> FilePath -> InputCCode -> ASTError i -> IO ()
82 | parsedMessage mest fpath xs (s, (i, etk)) = do
83 | putDocLnErr $
84 | bold (text fpath) <> bold (char ':') <>
85 | bold (text (show i)) <> bold (char ':') <+>
86 | messageColor mest (text $ show mest) <> messageColor mest (char ':') <+>
87 | text (T.unpack s)
88 | format (T.replicate 4 " " <> tshow (HT.tkLn i)) (pred $ fromIntegral $ HT.tkLn i) xs
89 | repSpace (HT.tkCn i) mest
90 | putDocLnErr $ messageColor mest (text $ replicate (pred $ HT.length etk) '~')
91 |
92 | -- | the function to output error message
93 | parsedErrExit :: (Integral i, Show i) => FilePath -> InputCCode -> ASTError i -> IO ()
94 | parsedErrExit fpath ccode err = parsedMessage ErrorMessage fpath ccode err >> exitFailure
95 |
96 | -- | the function to output warning message
97 | parsedWarn :: (Integral i, Show i) => FilePath -> InputCCode -> S.Seq (ASTError i) -> IO ()
98 | parsedWarn fpath xs warns = mapM_ (parsedMessage WarningMessage fpath xs) (toList warns)
99 |
100 | -- | Executor that receives information about the constructed AST,
101 | -- global variables, and literals and composes assembly code
102 | casm' :: (Integral e, Show e, Integral i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) => ASTs i -> GlobalVars i -> Literals i -> SI.Asm SI.AsmCodeCtx e ()
103 | casm' atl gvars lits = dataSection gvars lits >> textSection atl
104 |
105 | -- | Build AST from string of C source code
106 | buildAST :: (Integral i, Read i, Show i, Bits i) => InputCCode -> ASTResult i
107 | buildAST = HT.tokenize >=> parse
108 |
109 | -- | Print warning or error message if building AST from string of C source code has some problems
110 | execAST :: (Integral i, Read i, Show i, Bits i) => Bool -> FilePath -> InputCCode -> IO (Maybe (ASTs i, GlobalVars i, Literals i))
111 | execAST supWarns fpath ccode = flip (either ((<$) Nothing . parsedErrExit fpath ccode)) (buildAST ccode) $ \xs@(warns, _, _, _) ->
112 | Just (dropFst4 xs) <$ unless supWarns (parsedWarn fpath ccode warns)
113 |
--------------------------------------------------------------------------------
/src/Htcc/Asm/Intrinsic.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Asm.Intrinsic
3 | Description : The modules of intrinsic (x86_64) assembly
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The modules of intrinsic (x86_64) assembly
11 | -}
12 | module Htcc.Asm.Intrinsic (
13 | -- * Export modules
14 | module Htcc.Asm.Intrinsic.Register,
15 | module Htcc.Asm.Intrinsic.Operand
16 | ) where
17 |
18 | import Htcc.Asm.Intrinsic.Operand
19 | import Htcc.Asm.Intrinsic.Register
20 |
--------------------------------------------------------------------------------
/src/Htcc/Asm/Intrinsic/Operand.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Asm.Intrinsic.Register
3 | Description : Types and classes of the x86_64 operands
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Types and classes of the x86_64 operands
11 | -}
12 | {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}
13 |
14 | module Htcc.Asm.Intrinsic.Operand (
15 | -- * The operand classes and types.
16 | IsOperand (..),
17 | Operand (..),
18 | Ref (..)
19 | ) where
20 |
21 | import Control.Monad (liftM2)
22 | import Control.Monad.Fix (MonadFix (..), fix)
23 | import Control.Monad.Zip (MonadZip (..))
24 | import Data.Bits (Bits, FiniteBits)
25 | import Data.Tuple.Extra ((***))
26 | import Foreign.Storable (Storable)
27 | import GHC.Arr (Ix)
28 | import GHC.Generics (Generic, Generic1)
29 | import Htcc.Asm.Intrinsic.Register (Register (..))
30 |
31 | -- | The operand type.
32 | newtype Operand = Operand String -- ^ The constructor of `Operand`.
33 | deriving (Eq, Generic, Semigroup, Monoid, Ord)
34 |
35 | instance Show Operand where
36 | show (Operand x) = x
37 |
38 | -- | `IsOperand` class has an operand type as instances.
39 | class Show a => IsOperand a where
40 | -- | The operation of add.
41 | oadd :: IsOperand b => a -> b -> Operand
42 | oadd x y = Operand $ show x ++ "+" ++ show y
43 | -- | The operation of sub.
44 | osub :: IsOperand b => a -> b -> Operand
45 | osub x y = Operand $ show x ++ "-" ++ show y
46 | -- | The operation of mul.
47 | omul :: IsOperand b => a -> b -> Operand
48 | omul x y = Operand $ show x ++ "*" ++ show y
49 |
50 | instance IsOperand Operand
51 | instance IsOperand Int
52 | instance IsOperand Integer
53 | instance IsOperand Register
54 |
55 | -- | The type that specifies that register values are considered address values.
56 | -- e.g.:
57 | --
58 | -- >>> Ref rax
59 | -- [rax]
60 | -- >>> Ref rsp
61 | -- [rsp]
62 | -- >>> import qualified Data.Text as T
63 | -- >>> T.putStr $ mov rax (Ref rsp) <> add rsp 8
64 | -- mov rax, [rsp]
65 | -- add rsp, 8
66 | newtype Ref a = Ref -- ^ The constructor of `Ref`.
67 | {
68 | runRef :: a
69 | } deriving (
70 | Bits
71 | , Bounded
72 | , Enum
73 | , Eq
74 | , FiniteBits
75 | , Floating
76 | , Fractional
77 | , Generic
78 | , Generic1
79 | , Integral
80 | , Ix
81 | , Semigroup
82 | , Monoid
83 | , Num
84 | , Ord
85 | , Real
86 | , RealFrac
87 | , RealFloat
88 | , Storable
89 | )
90 |
91 | instance Functor Ref where
92 | fmap f (Ref x) = Ref $ f x
93 |
94 | instance Applicative Ref where
95 | pure = Ref
96 | (Ref f) <*> (Ref x) = Ref $ f x
97 |
98 | instance Monad Ref where
99 | return = pure
100 | (Ref x) >>= f = f x
101 |
102 | instance MonadFix Ref where
103 | mfix f = Ref (fix (runRef . f))
104 |
105 | instance MonadZip Ref where
106 | mzipWith = liftM2
107 | munzip (Ref x) = Ref *** Ref $ x
108 |
109 | instance IsOperand a => Show (Ref a) where
110 | show (Ref x) = "[" ++ show x ++ "]"
111 |
--------------------------------------------------------------------------------
/src/Htcc/Asm/Intrinsic/Structure.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Asm.Intrinsic.Structure
3 | Description : The modules of intrinsic (x86_64) assembly
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The modules of intrinsic (x86_64) assembly
11 | -}
12 | module Htcc.Asm.Intrinsic.Structure (
13 | module Htcc.Asm.Intrinsic.Structure.Internal
14 | ) where
15 |
16 | import Htcc.Asm.Intrinsic.Structure.Internal
17 |
--------------------------------------------------------------------------------
/src/Htcc/Asm/Intrinsic/Structure/Internal.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Asm.Intrinsic.Structure.Internal
3 | Description : The modules of intrinsic (x86_64) assembly
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The modules of intrinsic (x86_64) assembly
11 | -}
12 | {-# LANGUAGE OverloadedStrings, TupleSections #-}
13 | module Htcc.Asm.Intrinsic.Structure.Internal (
14 | Asm (..),
15 | AsmInfo (..),
16 | AsmCodeCtx,
17 | unCtx,
18 | runAsm,
19 | putStrWithIndent,
20 | putStrLnWithIndent,
21 | errCtx,
22 | writeCurFn,
23 | section,
24 | labeled
25 | ) where
26 |
27 | import Control.Monad.Finally (MonadFinally (..))
28 | import Data.IORef (IORef, newIORef, writeIORef)
29 | import qualified Data.Text as T
30 | import qualified Data.Text.IO as T
31 |
32 | import Htcc.Utils (err)
33 |
34 | -- | Counter and label information used when generating assembly code
35 | data AsmInfo e = AsmInfo
36 | {
37 | inLabel :: Bool, -- ^ the flag that indicates whether it is inside the label. If True, indent by single tab,
38 | lblCnt :: IORef e, -- ^ the label counter
39 | brkCnt :: IORef (Maybe e), -- ^ the @break@ label counter
40 | cntCnt :: IORef (Maybe e), -- ^ the @continue@ label counter
41 | curFn :: IORef (Maybe T.Text) -- ^ the function being processed
42 | }
43 |
44 | -- | A monad that represents the context of the assembly code
45 | newtype Asm ctx e a = Asm
46 | {
47 | unAsm :: AsmInfo e -> IO a -- ^ Function that determines the structure of assembly code
48 | }
49 |
50 | instance Functor (Asm ctx e) where
51 | fmap f asm = Asm $ fmap f . unAsm asm
52 |
53 | instance Applicative (Asm ctx e) where
54 | pure = Asm . const . return
55 | f <*> x = Asm (\ai -> unAsm f ai <*> unAsm x ai)
56 |
57 | instance Monad (Asm ctx e) where
58 | return = pure
59 | x >>= f = Asm (\ai -> unAsm x ai >>= flip unAsm ai . f)
60 |
61 | instance MonadFinally (Asm ctx e) where
62 | bracket' a r mc = do
63 | r' <- a
64 | a' <- mc r'
65 | (a',) <$> r r' (Just a')
66 |
67 | instance Semigroup (Asm ctx e a) where
68 | (<>) = (*>)
69 |
70 | instance Monoid a => Monoid (Asm ctx e a) where
71 | mempty = Asm $ const $ return mempty
72 | mappend = (<>)
73 |
74 | -- | Type representing assembly code
75 | data AsmCodeCtx
76 |
77 | -- | the function to switch context
78 | unCtx :: Asm ctx e a -> Asm ctx' e a
79 | unCtx = Asm . unAsm
80 |
81 | -- | the executor that outputs assembly code
82 | runAsm :: (Num e, Enum e) => Asm AsmCodeCtx e a -> IO a
83 | runAsm asm = do
84 | putStrLn ".intel_syntax noprefix"
85 | c <- newIORef 0
86 | brk <- newIORef Nothing
87 | cnt <- newIORef Nothing
88 | fn <- newIORef Nothing
89 | unAsm asm (AsmInfo False c brk cnt fn)
90 |
91 | -- | print a string with indentation, output is broken on a new line
92 | putStrLnWithIndent :: T.Text -> Asm ctx e ()
93 | putStrLnWithIndent s = Asm $ \x -> T.putStrLn $ if inLabel x then '\t' `T.cons` s else s
94 |
95 | -- | print a string with indentation
96 | putStrWithIndent :: T.Text -> Asm ctx e ()
97 | putStrWithIndent s = Asm $ \x -> T.putStr $ if inLabel x then '\t' `T.cons` s else s
98 |
99 | -- | The error context.
100 | -- when this is executed,
101 | -- it will exit the application immediately with `System.Exit.exitFailure` after printing the message.
102 | errCtx :: T.Text -> Asm ctx e ()
103 | errCtx = Asm . const . err
104 |
105 | -- | rewriting functions during processing
106 | writeCurFn :: Maybe T.Text -> Asm ctx e ()
107 | writeCurFn fname = Asm $ \x -> writeIORef (curFn x) fname
108 |
109 | -- | represents a section of assembly code
110 | section :: T.Text -> Asm ctx e a -> Asm AsmCodeCtx e a
111 | section sec asm = putStrLnWithIndent ('.' `T.cons` sec) *> unCtx asm
112 |
113 | -- | switch to process in label
114 | labeled :: Asm ctx e a -> Asm ctx e a
115 | labeled asm = Asm $ \x -> unAsm asm $ x { inLabel = True }
116 |
--------------------------------------------------------------------------------
/src/Htcc/Asm/Intrinsic/Structure/Section/Data.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Asm.Intrinsic.Structure.Section.Data
3 | Description : The modules of intrinsic (x86_64) assembly
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The modules of intrinsic (x86_64) assembly
11 | -}
12 | {-# LANGUAGE OverloadedStrings #-}
13 | module Htcc.Asm.Intrinsic.Structure.Section.Data (
14 | DataSectionCtx,
15 | DataLabelCtx,
16 | dAta,
17 | label,
18 | byte,
19 | sbyte,
20 | ascii,
21 | asciiz,
22 | zero,
23 | quad,
24 | ) where
25 |
26 | import qualified Data.ByteString as B
27 | import qualified Data.Text as T
28 | import qualified Htcc.Asm.Intrinsic.Structure.Internal as C
29 | import Numeric.Natural
30 |
31 | import Htcc.Utils (tshow)
32 |
33 | -- | the type representing the context inside the data section
34 | data DataSectionCtx
35 |
36 | -- | the type representing the context inside the data label
37 | data DataLabelCtx
38 |
39 | -- | data section
40 | dAta :: C.Asm DataSectionCtx e a -> C.Asm C.AsmCodeCtx e a
41 | dAta = C.section "data"
42 |
43 | -- | label in data section.
44 | label :: T.Text -> C.Asm DataLabelCtx e a -> C.Asm DataSectionCtx e a
45 | label lbl asm = C.putStrLnWithIndent (lbl <> ":") *> C.unCtx (C.labeled asm)
46 |
47 | -- | @byte@ in data section
48 | byte :: B.ByteString -> C.Asm DataLabelCtx e ()
49 | byte = C.putStrLnWithIndent . T.append ".byte " . T.intercalate ", " . map tshow . B.unpack
50 |
51 | -- | @.x.byte@ in data section
52 | sbyte :: (Num i, Show i) => Natural -> i -> C.Asm DataLabelCtx e ()
53 | sbyte sz val
54 | | sz == 1 = C.putStrLnWithIndent $ ".byte " <> tshow val
55 | | otherwise = C.putStrLnWithIndent $ "." <> tshow sz <> "byte " <> tshow val
56 |
57 | -- | @ascii@ in data section
58 | ascii :: B.ByteString -> C.Asm DataLabelCtx e ()
59 | ascii = C.putStrLnWithIndent . T.append ".ascii " . tshow
60 |
61 | -- | @asciiz@ in data section
62 | asciiz :: B.ByteString -> C.Asm DataLabelCtx e ()
63 | asciiz = byte . (`B.append` "\0")
64 |
65 | -- | @zero@ in data section
66 | zero :: Natural -> C.Asm DataLabelCtx e ()
67 | zero = C.putStrLnWithIndent . T.append ".zero " . tshow
68 |
69 | -- | @quad@ in data section
70 | quad :: T.Text -> C.Asm DataLabelCtx e ()
71 | quad = C.putStrLnWithIndent . T.append ".quad "
72 |
73 |
--------------------------------------------------------------------------------
/src/Htcc/Asm/Intrinsic/Structure/Section/Text.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Asm.Intrinsic.Structure.Section.Text
3 | Description : The modules of intrinsic (x86_64) assembly
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The modules of intrinsic (x86_64) assembly
11 | -}
12 | module Htcc.Asm.Intrinsic.Structure.Section.Text (
13 | module Htcc.Asm.Intrinsic.Structure.Section.Text.Directive,
14 | module Htcc.Asm.Intrinsic.Structure.Section.Text.Instruction,
15 | module Htcc.Asm.Intrinsic.Structure.Section.Text.Operations
16 | ) where
17 |
18 | import Htcc.Asm.Intrinsic.Structure.Section.Text.Directive
19 | import Htcc.Asm.Intrinsic.Structure.Section.Text.Instruction
20 | import Htcc.Asm.Intrinsic.Structure.Section.Text.Operations
21 |
--------------------------------------------------------------------------------
/src/Htcc/Asm/Intrinsic/Structure/Section/Text/Directive.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Asm.Intrinsic.Structure.Section.Text.Directive
3 | Description : The modules of intrinsic (x86_64) assembly
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The modules of intrinsic (x86_64) assembly
11 | -}
12 | {-# LANGUAGE LambdaCase, OverloadedStrings #-}
13 | module Htcc.Asm.Intrinsic.Structure.Section.Text.Directive (
14 | -- * Context type
15 | TextSectionCtx,
16 | TextLabelCtx,
17 | TargetLabelCtx,
18 | -- * Directives
19 | text,
20 | global,
21 | -- * Labels
22 | fn,
23 | label,
24 | begin,
25 | end,
26 | eLse,
27 | cAse,
28 | break,
29 | continue,
30 | gotoLabel,
31 | ref,
32 | refBegin,
33 | refEnd,
34 | refElse,
35 | refBreak,
36 | refHBreak,
37 | refContinue,
38 | refHContinue,
39 | refReturn,
40 | refGoto,
41 | -- * Generator
42 | makeCases
43 | ) where
44 |
45 | import Control.Monad (forM, unless)
46 | import Data.IORef (IORef, modifyIORef,
47 | readIORef)
48 | import Data.Maybe (fromJust, isJust)
49 | import qualified Data.Text as T
50 | import qualified Data.Text.IO as T
51 | import Prelude hiding (break)
52 |
53 | import qualified Htcc.Asm.Intrinsic.Structure.Internal as C
54 | import Htcc.Parser.AST.Core (ATKind (..), ATree (..))
55 | import Htcc.Utils (err, tshow)
56 |
57 | -- | the type representing the context inside the text section
58 | data TextSectionCtx
59 |
60 | -- | the type representing the context inside the label
61 | data TextLabelCtx
62 |
63 | -- | the type representing the context inside the instruction that needs to be specified,
64 | -- such as a @jmp@ instruction.
65 | data TargetLabelCtx
66 |
67 | -- | @text@ section
68 | text :: C.Asm TextSectionCtx e a -> C.Asm C.AsmCodeCtx e a
69 | text = C.section "text"
70 |
71 | -- | @global@ directive
72 | global :: T.Text -> C.Asm TextSectionCtx e ()
73 | global = C.putStrLnWithIndent . T.append ".global "
74 |
75 | -- | the label as function definition in text section
76 | fn :: T.Text -> C.Asm TextLabelCtx e a -> C.Asm TextSectionCtx e a
77 | fn fname asm = C.writeCurFn (Just fname) *>
78 | C.putStrLnWithIndent (fname <> ":") *>
79 | C.unCtx (C.labeled asm)
80 |
81 | -- | the label in text section
82 | label :: (Show i, Show e) => T.Text -> i -> C.Asm TextLabelCtx e ()
83 | label lbl n = C.Asm $ \x -> do
84 | cf <- readIORef $ C.curFn x
85 | unless (isJust cf) $ err "stray label"
86 | T.putStrLn $ ".L." <> lbl <> "." <> fromJust cf <> "." <> tshow n <> ":"
87 |
88 | -- | goto label
89 | gotoLabel :: T.Text -> C.Asm TextLabelCtx e ()
90 | gotoLabel ident = C.Asm $ \x -> do
91 | cf <- readIORef $ C.curFn x
92 | unless (isJust cf) $ err "stray goto label"
93 | T.putStrLn $ ".L.label." <> fromJust cf <> "." <> ident <> ":"
94 |
95 | -- | begin label
96 | begin :: (Show e, Show i) => i -> C.Asm TextLabelCtx e ()
97 | begin = label "begin"
98 |
99 | -- | end label
100 | end :: (Show e, Show i) => i -> C.Asm TextLabelCtx e ()
101 | end = label "end"
102 |
103 | -- | else label
104 | eLse :: (Show e, Show i) => i -> C.Asm TextLabelCtx e ()
105 | eLse = label "else"
106 |
107 | -- | case label
108 | cAse :: (Show e, Show i) => i -> C.Asm TextLabelCtx e ()
109 | cAse n = C.Asm $ \x -> do
110 | cf <- readIORef $ C.curFn x
111 | unless (isJust cf) $ err "stray case"
112 | T.putStrLn $ ".L.case." <> fromJust cf <> "." <> tshow n <> ":"
113 |
114 | -- | break label
115 | break :: (Show e, Show i) => i -> C.Asm TextLabelCtx e ()
116 | break = label "break"
117 |
118 | -- | continue label
119 | continue :: (Show e, Show i) => i -> C.Asm TextLabelCtx e ()
120 | continue = label "continue"
121 |
122 | -- | reference for return label
123 | refReturn :: Show e => C.Asm TargetLabelCtx e ()
124 | refReturn = C.Asm $ \x -> do
125 | cf <- readIORef (C.curFn x)
126 | unless (isJust cf) $ err "stray label"
127 | T.putStrLn $ ".L.return." <> fromJust cf
128 |
129 | refCnt :: Show e => (C.AsmInfo a -> IORef (Maybe e)) -> T.Text -> C.Asm ctx a ()
130 | refCnt f mes = C.Asm $ \x -> do
131 | cf <- readIORef (C.curFn x)
132 | unless (isJust cf) $ err $ "stray " <> mes
133 | n <- readIORef (f x)
134 | unless (isJust n) $ err $ "stray " <> mes
135 | T.putStrLn $ ".L." <> mes <> "." <> fromJust cf <> "." <> tshow (fromJust n)
136 |
137 | -- | reference for break label
138 | refBreak :: (Show e, Show i) => i -> C.Asm TargetLabelCtx e ()
139 | refBreak = ref "break"
140 |
141 | -- | reference for break label (applying value by `Htcc.Asm.Intrinsic.Structure.Internal.brkCnt`)
142 | refHBreak :: Show e => C.Asm TargetLabelCtx e ()
143 | refHBreak = refCnt C.brkCnt "break"
144 |
145 | -- | reference for continue label
146 | refContinue :: (Show e, Show i) => i -> C.Asm TargetLabelCtx e ()
147 | refContinue = ref "continue"
148 |
149 | -- | reference for break label (applying value by `Htcc.Asm.Intrinsic.Structure.Internal.cntCnt`)
150 | refHContinue :: Show e => C.Asm TargetLabelCtx e ()
151 | refHContinue = refCnt C.cntCnt "continue"
152 |
153 | -- | reference for goto label
154 | refGoto :: T.Text -> C.Asm TargetLabelCtx e ()
155 | refGoto ident = C.Asm $ \x -> do
156 | cf <- readIORef (C.curFn x)
157 | unless (isJust cf) $ err "stray label"
158 | T.putStrLn $ ".L.label." <> fromJust cf <> "." <> ident
159 |
160 | -- | reference to begin label
161 | refBegin :: (Show e, Show i) => i -> C.Asm TargetLabelCtx e ()
162 | refBegin = ref "begin"
163 |
164 | -- | reference to end label
165 | refEnd :: (Show e, Show i) => i -> C.Asm TargetLabelCtx e ()
166 | refEnd = ref "end"
167 |
168 | -- | reference to else label
169 | refElse :: (Show e, Show i) => i -> C.Asm TargetLabelCtx e ()
170 | refElse = ref "else"
171 |
172 | -- | reference to general label
173 | ref :: (Show e, Show i) => T.Text -> i -> C.Asm TargetLabelCtx e ()
174 | ref lbl n = C.Asm $ \x -> do
175 | cf <- readIORef (C.curFn x)
176 | unless (isJust cf) $ err "stray label"
177 | T.putStrLn $ ".L." <> lbl <> "." <> fromJust cf <> "." <> tshow n
178 |
179 | -- | generate cases and return abstract tree
180 | makeCases :: (Show e, Enum e, Integral e, Show i, Num i) => [ATree i] -> C.Asm TextLabelCtx e [ATree i]
181 | makeCases cases = C.Asm $ \x -> do
182 | cf <- readIORef (C.curFn x)
183 | forM cases $ \case
184 | (ATNode (ATCase _ cn) t lhs rhs) -> do
185 | modifyIORef (C.lblCnt x) succ
186 | n' <- readIORef (C.lblCnt x)
187 | T.putStrLn $ "\tcmp rax, " <> tshow cn
188 | T.putStrLn $ "\tje .L.case." <> fromJust cf <> "." <> tshow n'
189 | return $ ATNode (ATCase (fromIntegral n') cn) t lhs rhs
190 | (ATNode (ATDefault _) t lhs rhs) -> do
191 | modifyIORef (C.lblCnt x) succ
192 | n' <- readIORef (C.lblCnt x)
193 | T.putStrLn $ "\tjmp .L.case." <> fromJust cf <> "." <> tshow n'
194 | return $ ATNode (ATDefault $ fromIntegral n') t lhs rhs
195 | at -> return at
196 |
--------------------------------------------------------------------------------
/src/Htcc/Asm/Intrinsic/Structure/Section/Text/Instruction.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Asm.Intrinsic.Structure.Section.Text.Instruction
3 | Description : The modules of intrinsic (x86_64) assembly
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The modules of intrinsic (x86_64) assembly
11 | -}
12 | {-# LANGUAGE OverloadedStrings #-}
13 | module Htcc.Asm.Intrinsic.Structure.Section.Text.Instruction (
14 | SizeUnit (..),
15 | UnaryInstruction (..),
16 | BinaryInstruction (..),
17 | Offset (..),
18 | Ptr (..),
19 | sete, setne, setl, setle, setg, setge,
20 | byte, word, dword,
21 | cqo, ret, leave,
22 | jmp, je, jne, jnz,
23 | call
24 | ) where
25 |
26 | import qualified Data.Text as T
27 | import Numeric.Natural
28 |
29 | import Htcc.Asm.Intrinsic.Operand (IsOperand (..),
30 | Ref (..))
31 | import Htcc.Asm.Intrinsic.Register (Register (..))
32 | import qualified Htcc.Asm.Intrinsic.Structure.Internal as I
33 | import Htcc.Asm.Intrinsic.Structure.Section.Text.Directive
34 | import Htcc.Utils (tshow)
35 |
36 | {-# INLINE intelSyntaxUnary #-}
37 | intelSyntaxUnary :: Show a => T.Text -> a -> I.Asm TextLabelCtx e ()
38 | intelSyntaxUnary inst arg = I.putStrLnWithIndent $ inst <> " " <> tshow arg
39 |
40 | {-# INLINE intelSyntaxBinary #-}
41 | intelSyntaxBinary :: (Show a, Show b) => T.Text -> a -> b -> I.Asm TextLabelCtx e ()
42 | intelSyntaxBinary inst lhs rhs = I.putStrLnWithIndent $ inst <> " " <> tshow lhs <> ", " <> tshow rhs
43 |
44 | -- | Unit of size of data to be loaded
45 | data SizeUnit = Byte -- ^ 8 bits
46 | | Word -- ^ 16 bits
47 | | DWord -- ^ 32 bits
48 | deriving (Eq, Ord, Enum, Bounded)
49 |
50 | instance Show SizeUnit where
51 | show Byte = "byte"
52 | show Word = "word"
53 | show DWord = "dword"
54 |
55 | -- | @offset@ instruction
56 | newtype Offset = Offset T.Text -- ^ The constructor of @offset@ instruction
57 |
58 | instance Show Offset where
59 | show (Offset s) = "offset " ++ T.unpack s
60 |
61 | -- | The @ptr@ instruction
62 | data Ptr a = Ptr SizeUnit (Ref a) -- ^ The constructor of @ptr@ instruction
63 |
64 | instance IsOperand a => Show (Ptr a) where
65 | show (Ptr u s) = show u ++ " ptr " ++ show s
66 |
67 | -- | @byte@ is a helper function for intuitively writing @byte@ instructions
68 | byte :: IsOperand a => (SizeUnit -> Ref a -> Ptr a) -> Ref a -> Ptr a
69 | byte = flip id Byte
70 |
71 | -- | @word@ is a helper function for intuitively writing @word@ instructions
72 | word :: IsOperand a => (SizeUnit -> Ref a -> Ptr a) -> Ref a -> Ptr a
73 | word = flip id Word
74 |
75 | -- | @dword@ is a helper function for intuitively writing @dword@ instructions
76 | dword :: IsOperand a => (SizeUnit -> Ref a -> Ptr a) -> Ref a -> Ptr a
77 | dword = flip id DWord
78 |
79 | -- | A class of x86_64 instructions with unary arguments.
80 | class Show a => UnaryInstruction a where
81 | -- | @push@ instruction
82 | push :: a -> I.Asm TextLabelCtx e ()
83 | push = intelSyntaxUnary "push"
84 | -- | @pop@ instruction
85 | pop :: a -> I.Asm TextLabelCtx e ()
86 | pop = intelSyntaxUnary "pop"
87 | -- | @pushl@ instruction
88 | pushl :: a -> I.Asm TextLabelCtx e ()
89 | pushl = intelSyntaxUnary "pushl"
90 | -- | @popl@ instruction
91 | popl :: a -> I.Asm TextLabelCtx e ()
92 | popl = intelSyntaxUnary "popl"
93 | -- | @idiv@ instruction
94 | idiv :: a -> I.Asm TextLabelCtx e ()
95 | idiv = intelSyntaxUnary "idiv"
96 | -- | @not@ instruction
97 | not :: a -> I.Asm TextLabelCtx e ()
98 | not = intelSyntaxUnary "not"
99 |
100 | -- | @sete@ instruction
101 | sete :: Register -> I.Asm TextLabelCtx e ()
102 | sete = intelSyntaxUnary "sete"
103 |
104 | -- | @setne@ instruction
105 | setne :: Register -> I.Asm TextLabelCtx e ()
106 | setne = intelSyntaxUnary "setne"
107 |
108 | -- | @setl@ instruction
109 | setl :: Register -> I.Asm TextLabelCtx e ()
110 | setl = intelSyntaxUnary "setl"
111 |
112 | -- | @setle@ instruction
113 | setle :: Register -> I.Asm TextLabelCtx e ()
114 | setle = intelSyntaxUnary "setle"
115 |
116 | -- | @setg@ instruction
117 | setg :: Register -> I.Asm TextLabelCtx e ()
118 | setg = intelSyntaxUnary "setg"
119 |
120 | -- | @setge@ instruction
121 | setge :: Register -> I.Asm TextLabelCtx e ()
122 | setge = intelSyntaxUnary "setge"
123 |
124 | instance UnaryInstruction Integer
125 | instance UnaryInstruction Int
126 | instance UnaryInstruction Natural
127 | instance UnaryInstruction Register
128 | instance UnaryInstruction Offset
129 | instance IsOperand a => UnaryInstruction (Ref a)
130 |
131 | -- | A class of x86_64 instructions with binary arguments.
132 | class Show a => BinaryInstruction a where
133 | -- | @mov@ instruction
134 | mov :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
135 | mov = intelSyntaxBinary "mov"
136 | -- | @movl@ instruction
137 | movl :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
138 | movl = intelSyntaxBinary "movl"
139 | -- | @movsx@ instruction
140 | movsx :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
141 | movsx = intelSyntaxBinary "movsx"
142 | -- | @movsxd@ instruction
143 | movsxd :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
144 | movsxd = intelSyntaxBinary "movsxd"
145 | -- | @movabs@ instruction
146 | movabs :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
147 | movabs = intelSyntaxBinary "movabs"
148 | -- | @movzb@ instruction
149 | movzb :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
150 | movzb = intelSyntaxBinary "movzb"
151 | -- | @cmp@ instruction
152 | cmp :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
153 | cmp = intelSyntaxBinary "cmp"
154 | -- | @add@ instruction
155 | add :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
156 | add = intelSyntaxBinary "add"
157 | -- | @sub@ instruction
158 | sub :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
159 | sub = intelSyntaxBinary "sub"
160 | -- | @imul@ instruction
161 | imul :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
162 | imul = intelSyntaxBinary "imul"
163 | -- | @and@ instruction
164 | and :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
165 | and = intelSyntaxBinary "and"
166 | -- | @or@ instruction
167 | or :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
168 | or = intelSyntaxBinary "or"
169 | -- | @xor@ instruction
170 | xor :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
171 | xor = intelSyntaxBinary "xor"
172 | -- | @shl@ instruction
173 | shl :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
174 | shl = intelSyntaxBinary "shl"
175 | -- | @sar@ instruction
176 | sar :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
177 | sar = intelSyntaxBinary "sar"
178 | -- @lea@ instruction
179 | lea :: BinaryInstruction b => a -> b -> I.Asm TextLabelCtx e ()
180 | lea = intelSyntaxBinary "lea"
181 |
182 | instance BinaryInstruction Integer
183 | instance BinaryInstruction Int
184 | instance BinaryInstruction Natural
185 | instance BinaryInstruction Register
186 | instance BinaryInstruction Offset
187 | instance (IsOperand a, BinaryInstruction a) => BinaryInstruction (Ptr a)
188 | instance IsOperand a => BinaryInstruction (Ref a)
189 |
190 | -- | @cqo@ instruction
191 | cqo :: I.Asm TextLabelCtx e ()
192 | cqo = I.putStrLnWithIndent "cqo"
193 |
194 | -- | @ret@ instruction
195 | ret :: I.Asm TextLabelCtx e ()
196 | ret = I.putStrLnWithIndent "ret"
197 |
198 | -- | @leave@ instruction
199 | leave :: I.Asm TextLabelCtx e ()
200 | leave = I.putStrLnWithIndent "leave"
201 |
202 | -- | @jmp@ instruction
203 | jmp :: I.Asm TargetLabelCtx e () -> I.Asm TextLabelCtx e ()
204 | jmp asm = I.putStrWithIndent "jmp " *> I.unCtx asm
205 |
206 | -- | @je@ instruction
207 | je :: I.Asm TargetLabelCtx e () -> I.Asm TextLabelCtx e ()
208 | je asm = I.putStrWithIndent "je " *> I.unCtx asm
209 |
210 | -- | @jne@ instruction
211 | jne :: I.Asm TargetLabelCtx e () -> I.Asm TextLabelCtx e ()
212 | jne asm = I.putStrWithIndent "jne " *> I.unCtx asm
213 |
214 | -- | @jnz@ instruction
215 | jnz :: I.Asm TargetLabelCtx e () -> I.Asm TextLabelCtx e ()
216 | jnz asm = I.putStrWithIndent "jnz " *> I.unCtx asm
217 |
218 | -- | @call@ instruction
219 | call :: T.Text -> I.Asm TextLabelCtx e ()
220 | call = intelSyntaxUnary "call"
221 |
222 |
--------------------------------------------------------------------------------
/src/Htcc/Asm/Intrinsic/Structure/Section/Text/Operations.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Asm.Intrinsic.Structure.Section.Text.Operations
3 | Description : The modules of intrinsic (x86_64) assembly
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The modules of intrinsic (x86_64) assembly
11 | -}
12 | module Htcc.Asm.Intrinsic.Structure.Section.Text.Operations (
13 | incrLbl,
14 | applyCnt,
15 | applyBrk,
16 | bracketBrkCnt
17 | ) where
18 |
19 | import Data.IORef (modifyIORef,
20 | readIORef,
21 | writeIORef)
22 | import Data.Tuple.Extra ((&&&))
23 |
24 | import Control.Monad.Finally (MonadFinally (..))
25 | import qualified Htcc.Asm.Intrinsic.Structure.Internal as C
26 | import Htcc.Asm.Intrinsic.Structure.Section.Text.Directive
27 | import Htcc.Utils (bothM,
28 | (*^*))
29 |
30 | -- | count up the internal label counter
31 | incrLbl :: Enum e => C.Asm TextLabelCtx e e
32 | incrLbl = C.Asm $ \x -> modifyIORef (C.lblCnt x) succ >> readIORef (C.lblCnt x)
33 |
34 | -- | apply value to cntCnt from the current label number
35 | applyCnt :: C.Asm ctx e ()
36 | applyCnt = C.Asm $ \x -> readIORef (C.lblCnt x) >>= writeIORef (C.cntCnt x) . Just
37 |
38 | -- | apply value to brkCnt from the current label number
39 | applyBrk :: C.Asm ctx e ()
40 | applyBrk = C.Asm $ \x -> readIORef (C.lblCnt x) >>= writeIORef (C.brkCnt x) . Just
41 |
42 | -- | Apply values from lblCnt to brkCnt and cntCnt in function execution scope,
43 | -- and return values to their original state when exiting the scope
44 | bracketBrkCnt :: C.Asm TextLabelCtx e () -> C.Asm TextLabelCtx e ()
45 | bracketBrkCnt mc = bracket
46 | (C.Asm $ bothM readIORef . (C.brkCnt &&& C.cntCnt))
47 | (\y -> C.Asm $ \x -> (writeIORef (C.brkCnt x) *^* writeIORef (C.cntCnt x)) y) $ const mc
48 |
--------------------------------------------------------------------------------
/src/Htcc/CRules.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.CRules
3 | Description : The modules of C Rules
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The modules of C Rules
11 | -}
12 | module Htcc.CRules (
13 | -- * Export modules
14 | module Htcc.CRules.Char,
15 | module Htcc.CRules.LexicalElements,
16 | module Htcc.CRules.Types
17 | ) where
18 |
19 | import Htcc.CRules.Char
20 | import Htcc.CRules.LexicalElements
21 | import Htcc.CRules.Types
22 |
--------------------------------------------------------------------------------
/src/Htcc/CRules/Char.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
2 | {-|
3 | Module : Htcc.CRules.Char
4 | Description : Characters rules of C language
5 | Copyright : (c) roki, 2019
6 | License : MIT
7 | Maintainer : falgon53@yahoo.co.jp
8 | Stability : experimental
9 | Portability : POSIX
10 |
11 | Characters rules of C language
12 | -}
13 | module Htcc.CRules.Char (
14 | -- * The definition of characters rules
15 | isValidChar,
16 | -- * The helper class for some string types
17 | GenericStr (..)
18 | ) where
19 |
20 | import Data.Char (isAlpha, isDigit)
21 | import qualified Data.Text as T
22 |
23 | import Htcc.Utils (lor, sop, sopText)
24 |
25 | -- | Return `True` if it is a valid character.
26 | isValidChar :: Char -> Bool
27 | isValidChar = lor [isAlpha, (=='_'), isDigit]
28 |
29 | -- | Class of type that can be treated as a set of characters.
30 | class GenericStr a where
31 | -- | Returns `True` if the set of characters is
32 | -- a valid C language characters.
33 | isValid :: a -> Bool
34 |
35 | instance GenericStr String where
36 | isValid [] = False
37 | isValid (x:xs) = [isAlpha, (=='_')] `lor` x && [isAlpha, (=='_'), isDigit] `sop` xs
38 |
39 | instance GenericStr T.Text where
40 | isValid xs
41 | | T.null xs = False
42 | | otherwise = [isAlpha, (=='_')] `lor` T.head xs && [isAlpha, (=='_'), isDigit] `sopText` T.tail xs
43 |
--------------------------------------------------------------------------------
/src/Htcc/CRules/LexicalElements.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.CRules.LexicalElements
3 | Description : LexicalElements of C language
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | LexicalElements of C language
11 | -}
12 | {-# LANGUAGE OverloadedStrings #-}
13 | module Htcc.CRules.LexicalElements (
14 | charOps,
15 | strOps2,
16 | strOps3
17 | ) where
18 |
19 | import qualified Data.Text as T
20 |
21 | {-# INLINE charOps #-}
22 | -- | Valid one characters as C language
23 | charOps :: String
24 | charOps = "+-*/()<>=;{},&|^%!~[].?:"
25 |
26 | {-# INLINE strOps2 #-}
27 | -- | Valid two characters as C language
28 | strOps2 :: [T.Text]
29 | strOps2 = [
30 | "<=",
31 | ">=",
32 | "==",
33 | "!=",
34 | "<<",
35 | ">>",
36 | "->",
37 | "++",
38 | "--",
39 | "+=",
40 | "-=",
41 | "*=",
42 | "/=",
43 | "&&",
44 | "||",
45 | "&=",
46 | "|=",
47 | "^="
48 | ]
49 |
50 | {-# INLINE strOps3 #-}
51 | -- | Valid three characters as C language
52 | strOps3 :: [T.Text]
53 | strOps3 = [
54 | "<<=",
55 | ">>="
56 | ]
57 |
--------------------------------------------------------------------------------
/src/Htcc/CRules/Preprocessor.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.CRules.Preprocessor
3 | Description : The rules of preprocessor of C language
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The rules of preprocessor of C language
11 | -}
12 | module Htcc.CRules.Preprocessor (
13 | module Htcc.CRules.Preprocessor.Core,
14 | module Htcc.CRules.Preprocessor.Punctuators
15 | ) where
16 |
17 | import Htcc.CRules.Preprocessor.Core
18 | import Htcc.CRules.Preprocessor.Punctuators
19 |
--------------------------------------------------------------------------------
/src/Htcc/CRules/Preprocessor/Core.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.CRules.Preprocessor.Core
3 | Description : The preprocessor
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The preprocessor
11 | -}
12 | module Htcc.CRules.Preprocessor.Core (
13 | preprocess
14 | ) where
15 |
16 | import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError)
17 | import qualified Htcc.Tokenizer.Token as HT
18 |
19 | -- | The function that executes a proprocess.
20 | -- __NOTE__: This is not yet implemented.
21 | preprocess :: [HT.TokenLC i] -> Either (ASTError i) [HT.TokenLC i]
22 | preprocess = Right . filter (not . HT.isTKMacro . snd)
23 |
--------------------------------------------------------------------------------
/src/Htcc/CRules/Preprocessor/Punctuators.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.CRules.Preprocessor.Punctuators
3 | Description : The puncuators of preprocessor
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The puncuators of preprocessor
11 | -}
12 | {-# LANGUAGE DeriveGeneric #-}
13 | module Htcc.CRules.Preprocessor.Punctuators (
14 | -- * The define of C preprocessor
15 | bgMacro,
16 | Macros (..),
17 | -- * Utilities
18 | macros,
19 | length
20 | ) where
21 |
22 | import Control.DeepSeq (NFData (..))
23 | import GHC.Generics (Generic)
24 | import Prelude hiding (length)
25 | import qualified Prelude as P (length)
26 |
27 | {-# INLINE bgMacro #-}
28 | -- | `bgMacro` is the character that starts the macro, so it is @#@
29 | bgMacro :: Char
30 | bgMacro = '#'
31 |
32 | -- | `Macros` is a macro token defined in C.
33 | data Macros = MacInclude -- ^ the @include@
34 | deriving (Eq, Enum, Generic)
35 |
36 | instance NFData Macros
37 |
38 | instance Show Macros where
39 | show MacInclude = "include"
40 |
41 | {-# INLINE macros #-}
42 | -- | all macros
43 | macros :: [Macros]
44 | macros = enumFrom $ toEnum 0
45 |
46 | {-# INLINE length #-}
47 | -- | the length of the macro
48 | length :: Macros -> Int
49 | length = P.length . show
50 |
--------------------------------------------------------------------------------
/src/Htcc/CRules/Types.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.CRules.Types
3 | Description : The rules of types of C language
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The rules of types of C language
11 | -}
12 | module Htcc.CRules.Types (
13 | module Htcc.CRules.Types.CType,
14 | module Htcc.CRules.Types.TypeKind,
15 | module Htcc.CRules.Types.StorageClass
16 | ) where
17 |
18 | import Htcc.CRules.Types.CType
19 | import Htcc.CRules.Types.StorageClass
20 | import Htcc.CRules.Types.TypeKind
21 |
--------------------------------------------------------------------------------
/src/Htcc/CRules/Types/CType.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.CRules.Types.CType
3 | Description : The rules of types of C language
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The rules of types of C language
11 | -}
12 | module Htcc.CRules.Types.CType (
13 | CType (..)
14 | ) where
15 |
16 | import Numeric.Natural
17 |
18 | -- | A data type representing the type of C language
19 | class CType a where
20 | -- | `isFundamental` returns `True` only if the type is fundamental type (See also: § 3.9.1), otherwise retunrs `False`.
21 | isFundamental :: a -> Bool
22 | -- | If the first argument is a type qualifier,
23 | -- `qualify` returns a type that qualifies the type of the second argument with that qualifier.
24 | -- Otherwise `Nothing` is returned.
25 | qualify :: a -> a -> Maybe a
26 | -- | `sizeof` returns the byte size of the type defined by C language.
27 | sizeof :: a -> Natural
28 | -- | `alignof` returns the alignment of the type defiend by C language.
29 | alignof :: a -> Natural
30 | -- | `deref` returns @Just x@ for the underlying type @x@ only if @a@ is `Htcc.CRules.Types.Core.CTPtr` or `Htcc.CRules.Types.Core.CTArray`.
31 | -- Otherwise returns `Nothing`.
32 | deref :: a -> Maybe a
33 | -- | `ctorPtr` returns a convolution function with \(n\) specified pointers nested
34 | ctorPtr :: Natural -> a -> a
35 | -- | `dctorPtr` deconstructs the nested structure of `Htcc.CRules.Types.Core.CTPtr` and returns the convolution function
36 | -- of the original type and `Htcc.CRules.Types.Core.CTPtr`
37 | dctorPtr :: a -> (a, a -> a)
38 | -- | `dctorArray` deconstructs the nested structure of `Htcc.CRules.Types.Core.CTArray` and returns the convolution function
39 | -- of the original type and `Htcc.CRules.Types.Core.CTArray`
40 | dctorArray :: a -> (a, a -> a)
41 | -- | `removeAllExtents` is the same as @std::remove_all_extents@ defined in C++11 @\@
42 | -- (See also: /§ 20.9.7.4) header.
43 | -- If type @T@ is a multidimensional array of type @X@, type @X@ is returned.
44 | -- Otherwise, it returns type @T@.
45 | removeAllExtents :: a -> a
46 | -- | `conversion` defines one type from two types according to the implicit conversion defined in §6.3.1.8
47 | conversion :: a -> a -> a
48 | -- | `implicitInt` sets long or short type declarations for type declarations with only modifiers such as long and short.
49 | -- Otherwise, nothing to do.
50 | implicitInt :: a -> a
51 |
--------------------------------------------------------------------------------
/src/Htcc/CRules/Types/StorageClass.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.CRules.Types.StorageClass
3 | Description : The storage-class of C language
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The storage-class of C language
11 | -}
12 | {-# LANGUAGE DeriveGeneric #-}
13 | module Htcc.CRules.Types.StorageClass (
14 | -- * StorageClass data type and class
15 | StorageClass (..),
16 | StorageClassBase (..)
17 | ) where
18 |
19 | import Control.DeepSeq (NFData (..))
20 | import Data.Tuple.Extra (first, second)
21 | import GHC.Generics (Generic)
22 |
23 | import Htcc.CRules.Types.CType
24 | import Htcc.CRules.Types.TypeKind
25 |
26 | -- | The data type representing `StorageClass`
27 | data StorageClass i = SCAuto (TypeKind i) -- ^ The @auto@ keyword
28 | | SCStatic (TypeKind i) -- ^ The @static@ keyword
29 | | SCRegister (TypeKind i) -- ^ The @register@ keyword
30 | | SCUndef (TypeKind i) -- ^ `SCUndef` is used when storage-class specifier is not defined
31 | deriving (Eq, Generic)
32 |
33 | -- | Class to a type based on `StorageClass`.
34 | class StorageClassBase a where
35 | -- | When the given argument is `SCStatic`, `isSCStatic` returns `True`, otherwise `False`.
36 | isSCStatic :: a i -> Bool
37 |
38 | {-# INLINE fromsc #-}
39 | -- | Take type from `StorageClass`
40 | fromsc :: StorageClass i -> TypeKind i
41 | fromsc (SCAuto t) = t
42 | fromsc (SCStatic t) = t
43 | fromsc (SCRegister t) = t
44 | fromsc (SCUndef t) = t
45 |
46 | {-# INLINE picksc #-}
47 | -- | Take storage-class from `StorageClass`
48 | picksc :: StorageClass i -> TypeKind j -> StorageClass j
49 | picksc (SCAuto _) = SCAuto
50 | picksc (SCStatic _) = SCStatic
51 | picksc (SCRegister _) = SCRegister
52 | picksc (SCUndef _) = SCUndef
53 |
54 | {-# INLINE isSameSC #-}
55 | isSameSC :: StorageClass i -> StorageClass i -> Bool
56 | isSameSC (SCAuto _) (SCAuto _) = True
57 | isSameSC (SCStatic _) (SCStatic _) = True
58 | isSameSC (SCRegister _) (SCRegister _) = True
59 | isSameSC (SCUndef _) (SCUndef _) = True
60 | isSameSC _ _ = False
61 |
62 | instance Ord i => Ord (StorageClass i) where
63 | compare x y = compare (toTypeKind x) (toTypeKind y)
64 |
65 | instance Show i => Show (StorageClass i) where
66 | show (SCAuto CTUndef) = "auto"
67 | show (SCAuto t) = "auto " ++ show t
68 | show (SCStatic CTUndef) = "static"
69 | show (SCStatic t) = "static " ++ show t
70 | show (SCRegister CTUndef) = "register"
71 | show (SCRegister t) = "register " ++ show t
72 | show (SCUndef CTUndef) = "undefined"
73 | show (SCUndef t) = show t
74 |
75 | instance Ord i => CType (StorageClass i) where
76 | isFundamental = isFundamental . toTypeKind
77 | qualify x y
78 | | isSameSC x y = picksc x <$> qualify (toTypeKind x) (toTypeKind y)
79 | | otherwise = Nothing
80 | sizeof = sizeof . toTypeKind
81 | alignof = alignof . toTypeKind
82 | deref x = picksc x <$> deref (toTypeKind x)
83 | ctorPtr n = mapTypeKind (ctorPtr n)
84 | dctorPtr x = first (picksc x) $ second (\f y -> picksc y $ f $ toTypeKind y) $ dctorPtr $ toTypeKind x
85 | dctorArray x = first (picksc x) $ second (\f y -> picksc y $ f $ toTypeKind y) $ dctorArray $ toTypeKind x
86 | removeAllExtents = mapTypeKind removeAllExtents
87 | conversion x y = SCAuto $ conversion (toTypeKind x) (toTypeKind y)
88 | implicitInt = mapTypeKind implicitInt
89 |
90 | instance TypeKindBase StorageClass where
91 | {-# INLINE isCTArray #-}
92 | isCTArray = isCTArray . toTypeKind
93 |
94 | {-# INLINE isArray #-}
95 | isArray = isArray . toTypeKind
96 |
97 | {-# INLINE isCTStruct #-}
98 | isCTStruct = isCTStruct . toTypeKind
99 |
100 | {-# INLINE isCTUndef #-}
101 | isCTUndef = isCTUndef . toTypeKind
102 |
103 | {-# INLINE isCTIncomplete #-}
104 | isCTIncomplete = isCTIncomplete . toTypeKind
105 |
106 | {-# INLINE makeCTArray #-}
107 | makeCTArray ns = mapTypeKind (makeCTArray ns)
108 |
109 | concatCTArray x y
110 | | isSameSC x y = picksc x <$> concatCTArray (toTypeKind x) (toTypeKind y)
111 | | otherwise = Nothing
112 |
113 | {-# INLINE toTypeKind #-}
114 | toTypeKind = fromsc
115 |
116 | {-# INLINE mapTypeKind #-}
117 | mapTypeKind f sc = picksc sc $ f $ toTypeKind sc
118 |
119 | instance IncompleteBase StorageClass where
120 | {-# INLINE isIncompleteArray #-}
121 | isIncompleteArray = isIncompleteArray . toTypeKind
122 | {-# INLINE isIncompleteStruct #-}
123 | isIncompleteStruct = isIncompleteStruct . toTypeKind
124 | {-# INLINE fromIncompleteStruct #-}
125 | fromIncompleteStruct = fromIncompleteStruct . toTypeKind
126 | {-# INLINE fromIncompleteArray #-}
127 | fromIncompleteArray = fromIncompleteArray . toTypeKind
128 | {-# INLINE isValidIncomplete #-}
129 | isValidIncomplete = isValidIncomplete . toTypeKind
130 |
131 | instance StorageClassBase StorageClass where
132 | {-# INLINE isSCStatic #-}
133 | isSCStatic (SCStatic _) = True
134 | isSCStatic _ = False
135 |
136 | instance NFData i => NFData (StorageClass i)
137 |
--------------------------------------------------------------------------------
/src/Htcc/Parser.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser
3 | Description : Parsing and constructing AST from string
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Parsing and constructing AST from string
11 | -}
12 | module Htcc.Parser (
13 | module Htcc.Parser.AST,
14 | module Htcc.Parser.Parsing
15 | ) where
16 |
17 | import Htcc.Parser.AST
18 | import Htcc.Parser.Parsing
19 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/AST.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.AST
3 | Description : Data types and type synonyms used during AST construction
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Data types and type synonyms used during AST construction
11 | -}
12 | module Htcc.Parser.AST (
13 | module Htcc.Parser.AST.Core,
14 | module Htcc.Parser.AST.Type,
15 | module Htcc.Parser.AST.DeduceKind,
16 | module Htcc.Parser.AST.Var
17 | ) where
18 |
19 | import Htcc.Parser.AST.Core
20 | import Htcc.Parser.AST.DeduceKind
21 | import Htcc.Parser.AST.Type
22 | import Htcc.Parser.AST.Var
23 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/AST/DeduceKind.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.AST.DeduceKind
3 | Description : Data types and type synonyms used during AST construction
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Data types and type synonyms used during AST construction
11 | -}
12 | module Htcc.Parser.AST.DeduceKind (
13 | addKind,
14 | subKind
15 | ) where
16 |
17 | import Data.Maybe (isJust)
18 |
19 | import qualified Htcc.CRules.Types as CT
20 | import Htcc.Parser.AST.Core (ATKind (..), ATree (..))
21 |
22 | {-# INLINE addKind #-}
23 | -- | Constructs a numeric addition or pointer addition node according to the C language implicit conversion rules
24 | addKind :: (Eq i, Ord i, Show i) => ATree i -> ATree i -> Maybe (ATree i)
25 | addKind lhs rhs
26 | | all (CT.isFundamental . atype) [lhs, rhs] = Just $ ATNode ATAdd (CT.conversion (atype lhs) (atype rhs)) lhs rhs
27 | | isJust (CT.deref $ atype lhs) && CT.isFundamental (atype rhs) = Just $ ATNode ATAddPtr (atype lhs) lhs rhs
28 | | CT.isFundamental (atype lhs) && isJust (CT.deref $ atype rhs) = Just $ ATNode ATAddPtr (atype rhs) rhs lhs
29 | | otherwise = Nothing
30 |
31 | {-# INLINE subKind #-}
32 | -- | Constructs a number subtraction or pointer subtraction node according to the C language implicit conversion rules
33 | subKind :: (Eq i, Ord i) => ATree i -> ATree i -> Maybe (ATree i)
34 | subKind lhs rhs
35 | | all (CT.isFundamental . atype) [lhs, rhs] = Just $ ATNode ATSub (CT.conversion (atype lhs) (atype rhs)) lhs rhs
36 | | isJust (CT.deref $ atype lhs) && CT.isFundamental (atype rhs) = Just $ ATNode ATSubPtr (atype lhs) lhs rhs
37 | | all (isJust . CT.deref . atype) [lhs, rhs] = Just $ ATNode ATPtrDis (atype lhs) lhs rhs
38 | | otherwise = Nothing
39 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/AST/Type.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.AST.Type
3 | Description : Data types and type synonyms used during AST construction
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Data types and type synonyms used during AST construction
11 | -}
12 | module Htcc.Parser.AST.Type (
13 | ASTSuccess,
14 | ASTConstruction,
15 | ASTs,
16 | ASTResult,
17 | ASTState
18 | ) where
19 |
20 | import Htcc.Parser.AST.Core (ATree (..))
21 | import Htcc.Parser.ConstructionData.Core (ConstructionData,
22 | Warnings)
23 | import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError)
24 | import qualified Htcc.Parser.ConstructionData.Scope.Var as PV
25 | import qualified Htcc.Tokenizer as HT
26 | import Htcc.Utils.CompilationState (CompilationState)
27 |
28 | -- | The type to be used when the AST construction is successful
29 | type ASTSuccess i = ([HT.TokenLC i], ATree i, ConstructionData i)
30 |
31 | -- | Types used during AST construction
32 | type ASTConstruction i = Either (ASTError i) (ASTSuccess i)
33 |
34 | -- | The type of AST list
35 | type ASTs i = [ATree i]
36 |
37 | -- | A type that represents the result after AST construction. Quadraple of warning list, constructed abstract syntax tree list, global variable map, literal list.
38 | type ASTResult i = Either (ASTError i) (Warnings i, ASTs i, PV.GlobalVars i, PV.Literals i)
39 |
40 | -- | The type synonym of ASTState
41 | type ASTState i r = CompilationState (ConstructionData i) [HT.TokenLC i] i r
42 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/AST/Var.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.AST.Var
3 | Description : Data types and type synonyms used during AST construction
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Data types and type synonyms used during AST construction
11 | -}
12 | module Htcc.Parser.AST.Var (
13 | module Htcc.Parser.AST.Var.Init
14 | ) where
15 |
16 | import Htcc.Parser.AST.Var.Init
17 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/ConstructionData.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.ConstructionData.hs
3 | Description : Data types and type synonyms used during AST construction
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Data types and type synonyms used during AST construction
11 | -}
12 | module Htcc.Parser.ConstructionData (
13 | module Htcc.Parser.ConstructionData.Core
14 | ) where
15 |
16 | import Htcc.Parser.ConstructionData.Core
17 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/ConstructionData/Scope.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.ConstructionData.Scope
3 | Description : The Data type of scope and its utilities used in parsing
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The Data type of variables and its utilities used in parsing
11 | -}
12 | {-# LANGUAGE DeriveGeneric #-}
13 | module Htcc.Parser.ConstructionData.Scope (
14 | -- * The types
15 | Scoped (..),
16 | LookupVarResult (..),
17 | -- * Operations for scope
18 | addLVar,
19 | addGVar,
20 | addGVarWith,
21 | addLiteral,
22 | addTag,
23 | addTypedef,
24 | addFunction,
25 | addEnumerator,
26 | succNest,
27 | fallBack,
28 | lookupLVar,
29 | lookupGVar,
30 | lookupVar,
31 | lookupTag,
32 | lookupTypedef,
33 | lookupFunction,
34 | lookupEnumerator,
35 | initScope,
36 | resetLocal
37 | ) where
38 |
39 | import Control.DeepSeq (NFData (..))
40 | import Data.Bits (Bits (..))
41 | import qualified Data.Text as T
42 | import Data.Tuple.Extra (second)
43 | import GHC.Generics (Generic (..),
44 | Generic1 (..))
45 | import Numeric.Natural
46 |
47 | import qualified Htcc.CRules.Types as CT
48 | import Htcc.Parser.AST.Core (ATree (..))
49 | import qualified Htcc.Parser.ConstructionData.Scope.Enumerator as SE
50 | import qualified Htcc.Parser.ConstructionData.Scope.Function as PF
51 | import qualified Htcc.Parser.ConstructionData.Scope.ManagedScope as SM
52 | import qualified Htcc.Parser.ConstructionData.Scope.Tag as PS
53 | import qualified Htcc.Parser.ConstructionData.Scope.Typedef as PT
54 | import qualified Htcc.Parser.ConstructionData.Scope.Var as PV
55 | import qualified Htcc.Tokenizer.Token as HT
56 |
57 | -- | The data type of a struct tag
58 | data Scoped i = Scoped -- ^ The constructor of a struct tag
59 | {
60 | curNestDepth :: !Natural, -- ^ The nest depth of the parsing process
61 | vars :: PV.Vars i, -- ^ scoped all identifiers of variables (local variables, global variables and literals) visible during processing
62 | structs :: PS.Tags i, -- ^ scoped all struct tags
63 | typedefs :: PT.Typedefs i, -- ^ scoped all typedefs
64 | functions :: PF.Functions i, -- ^ scoped all identifires of functions
65 | enumerators :: SE.Enumerators i -- ^ scoped all identifiers of enumerators
66 | } deriving (Show, Generic, Generic1)
67 |
68 | instance NFData i => NFData (Scoped i)
69 |
70 | -- | A type that represents the result of a variable search
71 | data LookupVarResult i = FoundGVar (PV.GVar i) -- ^ A type constructor indicating that a global variable has been found
72 | | FoundLVar (PV.LVar i) -- ^ A type constructor indicating that a local variable has been found
73 | | FoundEnum (SE.Enumerator i) -- ^ A type constructor indicating that a enumerator has been found
74 | | NotFound -- ^ A type constructor indicating that it was not found
75 | deriving (Show, Eq)
76 |
77 | {-# INLINE applyVars #-}
78 | applyVars :: Scoped i -> (a, PV.Vars i) -> (a, Scoped i)
79 | applyVars sc = second (\x -> sc { vars = x })
80 |
81 | {-# INLINE addVar #-}
82 | addVar :: (Integral i, Bits i) => (CT.StorageClass i -> HT.TokenLC i -> PV.Vars i -> Either (T.Text, HT.TokenLC i) (ATree i, PV.Vars i)) -> CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (ATree i, Scoped i)
83 | addVar f ty tkn sc = applyVars sc <$> f ty tkn (vars sc)
84 |
85 | -- | `addLVar` has a scoped type argument and is the same function as `PV.addLVar` internally.
86 | {-# INLINE addLVar #-}
87 | addLVar :: (Integral i, Bits i) => CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (ATree i, Scoped i)
88 | addLVar ty tkn scp = addVar (PV.addLVar $ curNestDepth scp) ty tkn scp
89 |
90 | -- | `addGVar` has a scoped type argument and is the same function as `PV.addGVar` internally.
91 | {-# INLINE addGVar #-}
92 | addGVar :: (Integral i, Bits i) => CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (ATree i, Scoped i)
93 | addGVar = addVar PV.addGVar
94 |
95 | -- | `addGVarWith` has a scoped type argument and is the same function as `PV.addLiteral` internally.
96 | {-# INLINE addGVarWith #-}
97 | addGVarWith :: (Integral i, Bits i) => CT.StorageClass i -> HT.TokenLC i -> PV.GVarInitWith i -> Scoped i -> Either (SM.ASTError i) (ATree i, Scoped i)
98 | addGVarWith ty tkn iw sc = applyVars sc <$> PV.addGVarWith ty tkn iw (vars sc)
99 |
100 | -- | `addLiteral` has a scoped type argument and is the same function as `PV.addLiteral` internally.
101 | {-# INLINE addLiteral #-}
102 | addLiteral :: (Integral i, Bits i) => CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (ATree i, Scoped i)
103 | addLiteral = addVar PV.addLiteral
104 |
105 | -- | `succNest` has a scoped type argument and is the same function as `PV.succNest` internally.
106 | {-# INLINE succNest #-}
107 | succNest :: Scoped i -> Scoped i
108 | succNest sc = sc { curNestDepth = succ $ curNestDepth sc }
109 |
110 | -- | `fallBack` has a scoped type argument and is the same function as `PV.fallBack` internally.
111 | {-# INLINE fallBack #-}
112 | fallBack :: Scoped i -> Scoped i -> Scoped i
113 | fallBack pre post = pre
114 | {
115 | vars = PV.fallBack (vars pre) (vars post),
116 | structs = SM.fallBack (structs pre) (structs post),
117 | typedefs = SM.fallBack (typedefs pre) (typedefs post),
118 | functions = SM.fallBack (functions pre) (functions post),
119 | enumerators = SM.fallBack (enumerators pre) (enumerators post)
120 | }
121 |
122 | {-# INLINE lookupVar' #-}
123 | lookupVar' :: (T.Text -> PV.Vars a -> b) -> T.Text -> Scoped a -> b
124 | lookupVar' f s sc = f s $ vars sc
125 |
126 | -- | `lookupLVar` has a scoped type argument and is the same function as `PV.lookupLVar` internally.
127 | {-# INLINE lookupLVar #-}
128 | lookupLVar :: T.Text -> Scoped i -> Maybe (PV.LVar i)
129 | lookupLVar = lookupVar' PV.lookupLVar
130 |
131 | -- | `lookupGVar` has a scoped type argument and is the same function as `PV.lookupGVar` internally.
132 | {-# INLINE lookupGVar #-}
133 | lookupGVar :: T.Text -> Scoped i -> Maybe (PV.GVar i)
134 | lookupGVar = lookupVar' PV.lookupGVar
135 |
136 | -- | `lookupVar` has a scoped type argument and is the same function as `PV.lookupVar` internally.
137 | {-# INLINE lookupVar #-}
138 | lookupVar :: T.Text -> Scoped i -> LookupVarResult i
139 | lookupVar ident scp = case lookupLVar ident scp of
140 | Just local -> FoundLVar local
141 | _ -> case lookupEnumerator ident scp of
142 | Just enum -> FoundEnum enum
143 | _ -> maybe NotFound FoundGVar $ lookupGVar ident scp
144 |
145 | -- | `lookupTag` has a scoped type argument and is the same function as `PS.lookupTag` internally.
146 | {-# INLINE lookupTag #-}
147 | lookupTag :: T.Text -> Scoped i -> Maybe (PS.Tag i)
148 | lookupTag t sc = SM.lookup t $ structs sc
149 |
150 | -- | `lookupTypedef` has a scoped type argument and is the same function as `PT.lookupTypedef` internally.
151 | {-# INLINE lookupTypedef #-}
152 | lookupTypedef :: T.Text -> Scoped i -> Maybe (PT.Typedef i)
153 | lookupTypedef t sc = SM.lookup t $ typedefs sc
154 |
155 | -- | `lookupFunction` has a scoped type argument and is the same function as `PF.lookupFunction` internally.
156 | {-# INLINE lookupFunction #-}
157 | lookupFunction :: T.Text -> Scoped i -> Maybe (PF.Function i)
158 | lookupFunction t sc = SM.lookup t $ functions sc
159 |
160 | {-# INLINE lookupEnumerator #-}
161 | -- | `lookupEnumerator` has a scoped type argument and is the same function as `PF.lookupFunction` internally.
162 | lookupEnumerator :: T.Text -> Scoped i -> Maybe (SE.Enumerator i)
163 | lookupEnumerator t sc = SM.lookup t $ enumerators sc
164 |
165 | -- | `addTag` has a scoped type argument and is the same function as `PS.add` internally.
166 | {-# INLINE addTag #-}
167 | addTag :: Num i => CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (Scoped i)
168 | addTag ty tkn sc = (\x -> sc { structs = x }) <$> PS.add (curNestDepth sc) ty tkn (structs sc)
169 |
170 | -- | `addTypedef` has a scoped type argument and is the same function as `PT.add` internally.
171 | {-# INLINE addTypedef #-}
172 | addTypedef :: (Eq i, Num i) => CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (Scoped i)
173 | addTypedef ty tkn sc = (\x -> sc { typedefs = x }) <$> PT.add (curNestDepth sc) ty tkn (typedefs sc)
174 |
175 | -- | `addFunction` has a scoped type argument and is the same function as `PT.add` internally.
176 | {-# INLINE addFunction #-}
177 | addFunction :: Num i => Bool -> CT.StorageClass i -> HT.TokenLC i -> Scoped i -> Either (SM.ASTError i) (Scoped i)
178 | addFunction fd ty tkn sc = (\x -> sc { functions = x }) <$> PF.add fd ty tkn (functions sc)
179 |
180 | -- | `addEnumerator` has a scoped type argument and is the same function as `SE.add` internally.
181 | {-# INLINE addEnumerator #-}
182 | addEnumerator :: Num i => CT.StorageClass i -> HT.TokenLC i -> i -> Scoped i -> Either (SM.ASTError i) (Scoped i)
183 | addEnumerator ty tkn val sc = (\x -> sc { enumerators = x }) <$> SE.add ty tkn val (enumerators sc)
184 |
185 | {-# INLINE initScope #-}
186 | -- | Helper function representing an empty scoped data
187 | initScope :: Scoped i
188 | initScope = Scoped 0 PV.initVars SM.initial SM.initial SM.initial SM.initial
189 |
190 | {-# INLINE resetLocal #-}
191 | -- | `resetLocal` has a scoped type argument and is the same function as `PV.resetLocal` internally.
192 | resetLocal :: Scoped i -> Scoped i
193 | resetLocal sc = sc { vars = PV.resetLocal (vars sc) }
194 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/ConstructionData/Scope/Enumerator.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.ConstructionData.Scope.Enumerator
3 | Description : The Data type of typedef and its utilities used in parsing
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The Data type of variables and its utilities used in parsing
11 | -}
12 | {-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
13 | module Htcc.Parser.ConstructionData.Scope.Enumerator (
14 | Enumerator (..),
15 | Enumerators,
16 | add
17 | ) where
18 |
19 | import Control.DeepSeq (NFData (..))
20 | import qualified Data.Map as M
21 | import qualified Data.Text as T
22 | import GHC.Generics (Generic (..))
23 |
24 | import qualified Htcc.CRules.Types as CT
25 | import Htcc.Parser.AST.Core (Treealizable (..),
26 | atNumLit)
27 | import Htcc.Parser.ConstructionData.Scope.ManagedScope
28 | import Htcc.Parser.ConstructionData.Scope.Utils (internalCE)
29 | import qualified Htcc.Tokenizer.Token as HT
30 |
31 | -- | The data type of a enumerator
32 | data Enumerator i = Enumerator
33 | {
34 | enVal :: i, -- ^ The value of enumerator
35 | enUnderlying :: CT.StorageClass i -- ^ The underlying type of this enumerator
36 | } deriving (Eq, Ord, Show, Generic)
37 |
38 | instance NFData i => NFData (Enumerator i)
39 |
40 | instance Treealizable Enumerator where
41 | treealize (Enumerator val _) = atNumLit val
42 |
43 | instance ManagedScope (Enumerator i) where
44 | lookup = M.lookup
45 | fallBack = const
46 | initial = M.empty
47 |
48 | -- | The typedefs data typedefs
49 | type Enumerators i = M.Map T.Text (Enumerator i)
50 |
51 | -- | Given the flag (when that is added function, it is `True`. otherwise `False`), type, identifier token, and `Enumerators`,
52 | -- if the specified identifier already exists in the same scope,
53 | -- return an error message and its location as a pair.
54 | -- Otherwise, add a new tag to `Enumerators` and return it.
55 | -- If the token does not indicate an identifier, an error indicating internal compiler error is returned.
56 | add :: Num i => CT.StorageClass i -> HT.TokenLC i -> i -> Enumerators i -> Either (ASTError i) (Enumerators i)
57 | add t cur@(_, HT.TKIdent ident) val sts = case M.lookup ident sts of
58 | Just _ -> Left ("redeclaration of enumerator '" <> ident <> "'", cur) -- ODR
59 | Nothing -> Right $ M.insert ident (Enumerator val t) sts
60 | add _ _ _ _ = Left (internalCE, (HT.TokenLCNums 0 0, HT.TKEmpty))
61 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/ConstructionData/Scope/Function.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.ConstructionData.Scope.Function
3 | Description : The Data type of typedef and its utilities used in parsing
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The Data type of variables and its utilities used in parsing
11 | -}
12 | {-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
13 | module Htcc.Parser.ConstructionData.Scope.Function (
14 | Function (..),
15 | Functions,
16 | add
17 | ) where
18 |
19 | import Control.DeepSeq (NFData (..))
20 | import qualified Data.Map as M
21 | import qualified Data.Text as T
22 | import GHC.Generics (Generic (..))
23 |
24 | import qualified Htcc.CRules.Types as CT
25 | import Htcc.Parser.ConstructionData.Scope.ManagedScope
26 | import Htcc.Parser.ConstructionData.Scope.Utils (internalCE)
27 | import qualified Htcc.Tokenizer.Token as HT
28 |
29 | -- | The data type of a typedef tag
30 | data Function a = Function -- ^ The contypedefor of a typedef tag
31 | {
32 | fntype :: CT.StorageClass a, -- ^ The type of this typedef
33 | fnDefined :: Bool -- ^ If the function is defined, it will be `True`, otherwise will be `False`.
34 | } deriving (Eq, Ord, Show, Generic)
35 |
36 | instance NFData a => NFData (Function a)
37 |
38 | instance ManagedScope (Function i) where
39 | lookup = M.lookup
40 | fallBack = flip const
41 | initial = M.empty
42 |
43 | -- | The typedefs data typedefs
44 | type Functions i = M.Map T.Text (Function i)
45 |
46 | -- | Given the flag (when that is added function, it is `True`. otherwise `False`), type, identifier token, and `Functions`,
47 | -- if the specified identifier already exists in the same scope,
48 | -- return an error message and its location as a pair.
49 | -- Otherwise, add a new tag to `Functions` and return it.
50 | -- If the token does not indicate an identifier, an error indicating internal compiler error is returned.
51 | add :: Num i => Bool -> CT.StorageClass i -> HT.TokenLC i -> Functions i -> Either (ASTError i) (Functions i)
52 | add df t cur@(_, HT.TKIdent ident) sts = case M.lookup ident sts of
53 | Just foundFunc
54 | | not (fnDefined foundFunc) -> Right $ M.insert ident (Function t True) sts
55 | | otherwise -> Left ("conflicting types for '" <> ident <> "'", cur) -- ODR
56 | Nothing -> Right $ M.insert ident (Function t df) sts
57 | add _ _ _ _ = Left (internalCE, (HT.TokenLCNums 0 0, HT.TKEmpty))
58 |
59 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/ConstructionData/Scope/ManagedScope.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.ConstructionData.Scope.ManagedScope
3 | Description : The Data type of typedef and its utilities used in parsing
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The Data type of variables and its utilities used in parsing
11 | -}
12 | module Htcc.Parser.ConstructionData.Scope.ManagedScope (
13 | ManagedScope (..),
14 | ASTError
15 | ) where
16 |
17 | import qualified Data.Map as M
18 | import qualified Data.Text as T
19 | import Htcc.Tokenizer.Token (TokenLC)
20 |
21 | -- | Type classes common to concepts managed in scope
22 | class ManagedScope a where
23 | -- | `Htcc.Parser.Scope.ManagedScope.lookup` searches for something managed by the scope by the specified `T.Text` from @a@.
24 | lookup :: T.Text -> M.Map T.Text a -> Maybe a
25 | -- | Organize @a@ list state after scoping.
26 | fallBack :: M.Map T.Text a -> M.Map T.Text a -> M.Map T.Text a
27 | -- | Helper function representing an empty something managed by the scope
28 | initial :: M.Map T.Text a
29 |
30 | -- | The type to be used if an error occurs during AST construction.
31 | type ASTError i = (T.Text, TokenLC i)
32 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/ConstructionData/Scope/Tag.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.ConstructionData.Scope.Tag
3 | Description : The Data type of struct and its utilities used in parsing
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The Data type of variables and its utilities used in parsing
11 | -}
12 | {-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
13 | module Htcc.Parser.ConstructionData.Scope.Tag (
14 | Tag (..),
15 | Tags,
16 | add
17 | ) where
18 |
19 | import Control.DeepSeq (NFData (..))
20 | import qualified Data.Map as M
21 | import qualified Data.Text as T
22 | import GHC.Generics (Generic (..))
23 | import Numeric.Natural
24 |
25 | import qualified Htcc.CRules.Types as CT
26 | import Htcc.Parser.ConstructionData.Scope.ManagedScope
27 | import Htcc.Parser.ConstructionData.Scope.Utils (internalCE)
28 | import qualified Htcc.Tokenizer.Token as HT
29 |
30 | -- | The data type of a tag
31 | data Tag i = Tag -- ^ The constructor of a tag
32 | {
33 | sttype :: CT.StorageClass i, -- ^ The type of this tag
34 | stNestDepth :: !Natural -- ^ The nest depth of this tag
35 | } deriving (Eq, Ord, Show, Generic)
36 |
37 | instance NFData i => NFData (Tag i)
38 |
39 | instance ManagedScope (Tag i) where
40 | lookup = M.lookup
41 | fallBack = const
42 | initial = M.empty
43 |
44 | -- | The `Tags` data type
45 | type Tags i = M.Map T.Text (Tag i)
46 |
47 | -- | Given the current nesting number, type, identifier token, and `Tags`, if the specified identifier already exists in the same scope,
48 | -- return an error message and its location as a pair.
49 | -- Otherwise, add a new tag to `Tags` and return it.
50 | -- If the token does not indicate an identifier, an error indicating internal compiler error is returned.
51 | add :: Num i => Natural -> CT.StorageClass i -> HT.TokenLC i -> Tags i -> Either (ASTError i) (Tags i)
52 | add cnd t cur@(_, HT.TKIdent ident) sts = case M.lookup ident sts of
53 | Just foundedTag
54 | | stNestDepth foundedTag /= cnd -> stnat
55 | | CT.isCTIncomplete (sttype foundedTag) -> stnat
56 | | otherwise -> Left ("redefinition of 'struct " <> ident <> "'", cur) -- ODR
57 | Nothing -> stnat
58 | where
59 | stnat = Right $ M.insert ident (Tag t cnd) sts
60 | add _ _ _ _ = Left (internalCE, (HT.TokenLCNums 0 0, HT.TKEmpty))
61 |
62 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/ConstructionData/Scope/Typedef.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.ConstructionData.Scope.Typedef
3 | Description : The Data type of typedef and its utilities used in parsing
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The Data type of variables and its utilities used in parsing
11 | -}
12 | {-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
13 | module Htcc.Parser.ConstructionData.Scope.Typedef (
14 | Typedef (..),
15 | Typedefs,
16 | add
17 | ) where
18 |
19 | import Control.DeepSeq (NFData (..))
20 | import qualified Data.Map as M
21 | import qualified Data.Text as T
22 | import GHC.Generics (Generic (..))
23 | import Numeric.Natural
24 |
25 | import qualified Htcc.CRules.Types as CT
26 | import Htcc.Parser.ConstructionData.Scope.ManagedScope
27 | import Htcc.Parser.ConstructionData.Scope.Utils (internalCE)
28 | import qualified Htcc.Tokenizer.Token as HT
29 |
30 | -- | The data type of a typedef tag
31 | data Typedef a = Typedef -- ^ The contypedefor of a typedef tag
32 | {
33 | tdtype :: CT.StorageClass a, -- ^ The type of this typedef
34 | tdNestDepth :: !Natural -- ^ The nest depth of this typedef
35 | } deriving (Eq, Ord, Show, Generic)
36 |
37 | instance NFData i => NFData (Typedef i)
38 |
39 | instance ManagedScope (Typedef i) where
40 | lookup = M.lookup
41 | fallBack = const
42 | initial = M.empty
43 |
44 | -- | The typedefs data type
45 | type Typedefs a = M.Map T.Text (Typedef a)
46 |
47 | -- | Given the current nesting number, type, identifier token, and `Typedefs`, if the specified identifier already exists in the same scope,
48 | -- return an error message and its location as a pair.
49 | -- Otherwise, add a new tag to `Typedefs` and return it.
50 | -- If the token does not indicate an identifier, an error indicating internal compiler error is returned.
51 | add :: (Num i, Eq i) => Natural -> CT.StorageClass i -> HT.TokenLC i -> Typedefs i -> Either (ASTError i) (Typedefs i)
52 | add cnd t cur@(_, HT.TKIdent ident) sts = case M.lookup ident sts of
53 | Just foundedTag
54 | | tdNestDepth foundedTag /= cnd -> tdnat
55 | | tdtype foundedTag == t -> tdnat
56 | | otherwise -> Left ("conflicting types for '" <> ident <> "'", cur) -- ODR
57 | Nothing -> tdnat
58 | where
59 | tdnat = Right $ M.insert ident (Typedef t cnd) sts
60 | add _ _ _ _ = Left (internalCE, (HT.TokenLCNums 0 0, HT.TKEmpty))
61 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/ConstructionData/Scope/Utils.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.ConstructionData.Scope.Utils
3 | Description : Utilities used to handle scopes
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Utilities used to handle scopes
11 | -}
12 | {-# LANGUAGE OverloadedStrings #-}
13 | module Htcc.Parser.ConstructionData.Scope.Utils (
14 | internalCE
15 | ) where
16 |
17 | import qualified Data.Text as T
18 |
19 | {-# INLINE internalCE #-}
20 | -- | the message of an internal compiler error
21 | internalCE :: T.Text
22 | internalCE = "internal compiler error: Please submit a bug report with preprocessed source if appropriate.\nPlease see this repository: "
23 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/Parsing.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.Parsing
3 | Description : The main routines for parsing
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The main routines for parsing
11 | -}
12 | module Htcc.Parser.Parsing (
13 | module Htcc.Parser.Parsing.Core
14 | ) where
15 |
16 | import Htcc.Parser.Parsing.Core
17 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/Parsing/Core.hs-boot:
--------------------------------------------------------------------------------
1 | module Htcc.Parser.Parsing.Core where
2 |
3 | import Data.Bits (Bits)
4 | import Htcc.Tokenizer (TokenLC)
5 | import Htcc.Parser.ConstructionData (ConstructionData)
6 | import Htcc.Parser.AST (ATree, ASTConstruction)
7 | import qualified Htcc.Tokenizer as HT
8 |
9 | stmt :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i
10 |
11 | conditional :: (Show i, Read i, Integral i, Bits i) => [TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i
12 |
13 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/Parsing/Global.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE BangPatterns, LambdaCase, OverloadedStrings #-}
2 | {-|
3 | Module : Htcc.Parser.Parsing.Global
4 | Description : The C languge parser and AST constructor
5 | Copyright : (c) roki, 2019
6 | License : MIT
7 | Maintainer : falgon53@yahoo.co.jp
8 | Stability : experimental
9 | Portability : POSIX
10 |
11 | The module of the globals
12 | -}
13 | module Htcc.Parser.Parsing.Global (
14 | globalDef
15 | ) where
16 |
17 | import Data.Bits
18 |
19 | import Htcc.Parser.AST
20 | import Htcc.Parser.ConstructionData
21 | import Htcc.Parser.Parsing.Global.Function
22 | import Htcc.Parser.Parsing.Global.Var
23 | import Htcc.Parser.Parsing.Type (takeType)
24 | import Htcc.Parser.Parsing.Typedef
25 | import qualified Htcc.Tokenizer as HT
26 | import Htcc.Utils (uncurry4)
27 |
28 | -- | `globalDef` parses global definitions (include functions and global variables)
29 | -- \[
30 | -- \text{global-def}=\left(\text{global-var}\ \mid\ \text{function}\right)\text{*}
31 | -- \]
32 | globalDef :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i
33 | globalDef (cur@(_, HT.TKReserved "register"):_) _ _ = Left ("illegal storage class on file-scoped identifier", cur)
34 | globalDef (cur@(_, HT.TKReserved "auto"):_) _ _ = Left ("illegal storage class on file-scoped identifier", cur)
35 | globalDef xs@((_, HT.TKTypedef):_) _ sc = typedef xs sc -- for global @typedef@
36 | globalDef tks at !va = (>>=) (takeType tks va) $ \case
37 | (_, Nothing, (_, HT.TKReserved ";"):ds', scp) -> Right (ds', ATEmpty, scp) -- e.g., @int;@ is legal in C11 (See N1570/section 6.7 Declarations)
38 | (funcType, ident@(Just (_, HT.TKIdent _)), tk@((_, HT.TKReserved "("):_), !sc) -> function funcType ident tk at sc
39 | p@(_, Just (_, HT.TKIdent _), _, _) -> uncurry4 var p
40 | _ -> Left ("invalid definition of global identifier", HT.altEmptyToken tks)
41 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/Parsing/Global.hs-boot:
--------------------------------------------------------------------------------
1 | module Htcc.Parser.Parsing.Global where
2 |
3 | import Data.Bits
4 | import Htcc.Parser.AST
5 | import Htcc.Parser.ConstructionData
6 | import qualified Htcc.Tokenizer as HT
7 |
8 | globalDef :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i
9 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/Parsing/Global/Function.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE BangPatterns, LambdaCase, OverloadedStrings, ScopedTypeVariables,
2 | TupleSections #-}
3 | {-|
4 | Module : Htcc.Parser.Parsing.Global.Function
5 | Description : The C languge parser and AST constructor
6 | Copyright : (c) roki, 2019
7 | License : MIT
8 | Maintainer : falgon53@yahoo.co.jp
9 | Stability : experimental
10 | Portability : POSIX
11 |
12 | The function declaration
13 | -}
14 | module Htcc.Parser.Parsing.Global.Function (
15 | function
16 | ) where
17 |
18 | import Control.Monad.Loops (unfoldrM)
19 | import Control.Monad.ST (runST)
20 | import Data.Bits hiding (shift)
21 | import Data.List (find)
22 | import Data.List.Split (linesBy)
23 | import Data.Maybe (fromMaybe, isJust)
24 | import Data.STRef (newSTRef, readSTRef,
25 | writeSTRef)
26 | import Prelude hiding (toInteger)
27 |
28 | import qualified Htcc.CRules.Types as CT
29 | import Htcc.Parser.AST
30 | import Htcc.Parser.ConstructionData
31 | import Htcc.Parser.ConstructionData.Scope.Utils (internalCE)
32 | import {-# SOURCE #-} Htcc.Parser.Parsing.Core (stmt)
33 | import {-# SOURCE #-} Htcc.Parser.Parsing.Global (globalDef)
34 | import Htcc.Parser.Parsing.Type
35 | import Htcc.Parser.Utils
36 | import qualified Htcc.Tokenizer as HT
37 | import Htcc.Utils (maybe', maybeToRight,
38 | tshow)
39 |
40 | -- |
41 | -- \[
42 | -- \begin{array}{ccc}
43 | -- \text{function}&=&\text{pre-type}\ \text{declaration}\ \text{"("}\ \text{params?}\ \text{")"}\ \left(\text{"\{"}\ \text{stmt*}\ \text{"\}"}\ \mid\ \text{";"}\right)\\
44 | -- \text{params}&=&\text{params}\left(\text{","}\ \text{param}\right)\text{*}\\
45 | -- \text{param}&=&\text{pre-type}\ \text{declaration}\ \text{array-decl-suffix}
46 | -- \end{array}
47 | -- \]
48 | function :: (Show i, Read i, Integral i, Bits i) => CT.StorageClass i -> Maybe (HT.TokenLC i) -> [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i
49 | function funcType (Just cur@(_, HT.TKIdent fname)) tk@((_, HT.TKReserved "("):_) at !sc = let scp = resetLocal sc in
50 | (>>=) (maybeToRight (internalCE, cur) (takeBrace "(" ")" $ tail (cur:tk))) $
51 | either (Left . ("invalid function declaration/definition",)) $ \(fndec, st) -> case st of
52 | ((_, HT.TKReserved ";"):ds'') -> addFunction False funcType cur scp >>= globalDef ds'' at -- for a function declaration -- TODO: read types of parameters and register them
53 | ((_, HT.TKReserved "{"):_) -> (>>=) (addFunction True funcType cur scp) $ \scp' -> checkErr fndec scp' $ \args -> runST $ do -- for a function definition
54 | eri <- newSTRef Nothing
55 | v <- newSTRef scp'
56 | mk <- flip unfoldrM args $ \args' -> if null args' then return Nothing else let arg = head args' in do
57 | -- About @t'@:
58 | -- An array of type T is equivalent to a pointer of type T in the context of function parameters.
59 | m <- flip fmap (readSTRef v) $ \scp'' -> let (t, mident, _, _) = arg; t' = fromMaybe t $ aboutArray t in case mident of
60 | Nothing -> Left ("anonymouse variable is not implemented yet", cur) -- TODO
61 | Just ident -> addLVar t' ident scp''
62 | flip (either ((<$) Nothing . writeSTRef eri . Just)) m $ \(vat, scp'') -> Just (vat, tail args') <$ writeSTRef v scp''
63 | (>>=) (readSTRef eri) $ flip maybe (return . Left) $ flip fmap (readSTRef v) $ \v' -> (>>=) (stmt st at v') $ \case -- Forbid void to return a value in a return type function.
64 | (ert, erat@(ATNode (ATBlock block) _ _ _), erscp)
65 | | CT.toTypeKind funcType == CT.CTVoid -> if isJust (find isNonEmptyReturn block) then
66 | Left ("The return type of function '" <> fname <> "' is void, but the statement returns a value", cur) else
67 | Right (ert, atDefFunc fname (if null mk then Nothing else Just mk) funcType erat, erscp)
68 | | otherwise -> let fnode = atDefFunc fname (if null mk then Nothing else Just mk) funcType erat in
69 | maybe' (Right (ert, fnode, erscp)) (find isEmptyReturn block) $ const $
70 | Right (ert, fnode, pushWarn ("The return type of function '" <> fname <> "' is " <> tshow (CT.toTypeKind funcType) <> ", but the statement returns no value") cur erscp)
71 | _ -> Left (internalCE, HT.emptyToken)
72 | _ -> stmt tk at scp
73 | where
74 | checkErr ar !scp' f = let ar' = init $ tail ar in if not (null ar') && snd (head ar') == HT.TKReserved "," then Left ("unexpected ',' token", head ar') else
75 | let args = linesBy ((==HT.TKReserved ",") . snd) ar' in mapM (`takeType` scp') args >>= f
76 | aboutArray t
77 | | CT.isCTArray t = CT.mapTypeKind CT.CTPtr <$> CT.deref t
78 | | CT.isIncompleteArray t = Just $ CT.mapTypeKind (\(CT.CTIncomplete (CT.IncompleteArray t')) -> CT.CTPtr t') t
79 | | otherwise = Nothing
80 | function _ _ xs _ _ = Left (internalCE, HT.altEmptyToken xs)
81 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/Parsing/Global/Var.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables,
2 | TupleSections #-}
3 | {-|
4 | Module : Htcc.Parser.Parsing.Global.Var
5 | Description : The C languge parser and AST constructor
6 | Copyright : (c) roki, 2019
7 | License : MIT
8 | Maintainer : falgon53@yahoo.co.jp
9 | Stability : experimental
10 | Portability : POSIX
11 |
12 | The Global variable declaration
13 | -}
14 | module Htcc.Parser.Parsing.Global.Var (
15 | var
16 | ) where
17 |
18 | import Data.Bits hiding (shift)
19 | import Prelude hiding
20 | (toInteger)
21 |
22 | import qualified Htcc.CRules.Types as CT
23 | import Htcc.Parser.AST
24 | import Htcc.Parser.ConstructionData
25 | import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError)
26 | import Htcc.Parser.ConstructionData.Scope.Utils (internalCE)
27 | import qualified Htcc.Parser.ConstructionData.Scope.Var as PV
28 | import {-# SOURCE #-} Htcc.Parser.Parsing.Core (conditional)
29 | import Htcc.Parser.Parsing.Type
30 | import qualified Htcc.Tokenizer as HT
31 | import Htcc.Utils (maybeToRight,
32 | tshow)
33 |
34 | gvarInit :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> CT.StorageClass i -> HT.TokenLC i -> ConstructionData i -> Either (ASTError i) ([HT.TokenLC i], ConstructionData i)
35 | gvarInit xs ty ident sc = do
36 | (ds, ast, sc') <- conditional xs ATEmpty sc
37 | case (atkind ast, atkind (atL ast)) of
38 | (ATAddr, ATGVar _ name) -> (ds,) . snd <$> gvarInitWithOG ty ident name sc'
39 | (ATAddr, _) -> Left ("invalid initializer in global variable", HT.altEmptyToken ds)
40 | (ATGVar t name, _)
41 | | CT.isCTArray t -> (ds,) . snd <$> gvarInitWithOG ty ident name sc'
42 | | otherwise -> gvarInitWithVal ds sc'
43 | _ -> gvarInitWithVal ds sc'
44 | where
45 | gvarInitWithOG ty' from to = addGVarWith ty' from (PV.GVarInitWithOG to)
46 | gvarInitWithVal ds sc' = do
47 | (ds', cval) <- either (maybe (Left ("initializer element is not constant", HT.altEmptyToken ds)) Left) Right $ constantExp xs sc'
48 | (ds',) . snd <$> addGVarWith ty ident (PV.GVarInitWithVal cval) sc'
49 |
50 | -- | \[
51 | -- \text{global-var} = \text{pre-type}\ \text{declaration}\ \text{array-decl-suffix}\ \text{";"}
52 | -- \]
53 | var :: (Show i, Read i, Integral i, Bits i) => CT.StorageClass i -> Maybe (HT.TokenLC i) -> [HT.TokenLC i] -> ConstructionData i -> ASTConstruction i
54 | var ty (Just cur@(_, HT.TKIdent _)) xs !scp = case xs of
55 | (_, HT.TKReserved "="):ds -> do -- for initializing
56 | ty' <- maybeToRight ("defining global variables with a incomplete type", cur) (incomplete ty scp)
57 | (ds', nsc) <- gvarInit ds ty' cur scp
58 | case ds' of
59 | (_, HT.TKReserved ";"):ds'' -> return (ds'', ATEmpty, nsc)
60 | _ -> Left $ if null ds' then
61 | ("expected ';' token after '" <> tshow (snd cur) <> "' token", HT.altEmptyToken ds') else
62 | ("expected ';' token" <> (if null ds' then "" else " before '" <> tshow (snd $ head ds') <> "' token"), HT.altEmptyToken ds')
63 | (_, HT.TKReserved ";"):ds -> do -- for non initializing
64 | ty' <- maybeToRight ("defining global variables with a incomplete type", cur) (incomplete ty scp)
65 | (ds, ATEmpty,) . snd <$> addGVar ty' cur scp
66 | _ -> Left ("expected ';' token after '" <> tshow (snd cur) <> "' token", cur)
67 | var _ _ xs _ = Left (internalCE, HT.altEmptyToken xs)
68 |
69 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/Parsing/StmtExpr.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE BangPatterns, LambdaCase, OverloadedStrings, ScopedTypeVariables,
2 | TupleSections #-}
3 | {-|
4 | Module : Htcc.Parser.Parsing.StmtExpr
5 | Description : The C languge parser and AST constructor
6 | Copyright : (c) roki, 2019
7 | License : MIT
8 | Maintainer : falgon53@yahoo.co.jp
9 | Stability : experimental
10 | Portability : POSIX
11 |
12 | The module of the statement expression (GNU extension: )
13 | -}
14 | module Htcc.Parser.Parsing.StmtExpr (
15 | stmtExpr
16 | ) where
17 |
18 | import Control.Monad (when)
19 | import Control.Monad.Loops (unfoldrM)
20 | import Control.Monad.ST (runST)
21 | import Data.Bits hiding (shift)
22 | import Data.STRef (newSTRef, readSTRef,
23 | writeSTRef)
24 | import Prelude hiding (toInteger)
25 |
26 | import Htcc.Parser.AST
27 | import Htcc.Parser.ConstructionData
28 | import Htcc.Parser.ConstructionData.Scope.Utils (internalCE)
29 | import {-# SOURCE #-} Htcc.Parser.Parsing.Core (stmt)
30 | import Htcc.Parser.Utils
31 | import qualified Htcc.Tokenizer as HT
32 | import Htcc.Utils (maybeToRight, tshow)
33 |
34 | -- | statement expression (GNU extension: )
35 | -- \[\text{stmt-expr}=\text{"("}\ \text{"\{"}\ \text{stmt}\ \text{stmt*}\ \text{"\}"}\ \text{")"}\]
36 | stmtExpr :: (Show i, Read i, Integral i, Bits i) => [HT.TokenLC i] -> ATree i -> ConstructionData i -> ASTConstruction i
37 | stmtExpr ((_, HT.TKReserved "("):xs@((_, HT.TKReserved "{"):_)) _ !scp = (>>=) (maybeToRight (internalCE, head xs) (takeBrace "{" "}" xs)) $
38 | either (Left . ("the statement expression is not closed",)) $ \(sctk, ds) -> case ds of
39 | (_, HT.TKReserved ")"):ds' -> runST $ do
40 | eri <- newSTRef Nothing
41 | v <- newSTRef $ succNest scp
42 | lastA <- newSTRef ATEmpty
43 | mk <- flip unfoldrM (init $ tail sctk) $ \ert -> if null ert then return Nothing else do
44 | erscp <- readSTRef v
45 | flip (either $ \err -> Nothing <$ writeSTRef eri (Just err)) (stmt ert ATEmpty erscp) $ \(ert', erat', erscp') ->
46 | Just (erat', ert') <$ (writeSTRef v erscp' >> when (case erat' of ATEmpty -> False; _ -> True) (writeSTRef lastA erat'))
47 | (>>=) (readSTRef eri) $ flip maybe (return . Left) $ do
48 | v' <- readSTRef v
49 | flip fmap (readSTRef lastA) $ \case
50 | (ATNode ATExprStmt _ lhs _) -> Right (ds', atNoLeaf (ATStmtExpr (init mk ++ [lhs])) (atype lhs), fallBack scp v')
51 | _ -> Left ("void value not ignored as it ought to be. the statement expression starts here:", head xs)
52 | _ -> Left $ if null sctk then ("expected ')' token. the statement expression starts here: ", head xs) else
53 | ("expected ')' token after '" <> tshow (snd $ last sctk) <> "' token", last sctk)
54 | stmtExpr xs _ _ = Left (internalCE, HT.altEmptyToken xs)
55 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/Parsing/Typedef.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables,
2 | TupleSections #-}
3 | {-|
4 | Module : Htcc.Parser.Parsing.Typedef
5 | Description : The C languge parser and AST constructor
6 | Copyright : (c) roki, 2019
7 | License : MIT
8 | Maintainer : falgon53@yahoo.co.jp
9 | Stability : experimental
10 | Portability : POSIX
11 |
12 | Perspective on @typedef@ declaration
13 | -}
14 | module Htcc.Parser.Parsing.Typedef (
15 | typedef
16 | ) where
17 |
18 | import Data.Bits (Bits)
19 |
20 | import Htcc.Parser.AST
21 | import Htcc.Parser.ConstructionData
22 | import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError)
23 | import Htcc.Parser.ConstructionData.Scope.Utils (internalCE)
24 | import Htcc.Parser.Parsing.Type
25 | import qualified Htcc.Tokenizer as HT
26 | import Htcc.Utils (maybeToRight,
27 | tshow)
28 |
29 | -- | Perform type definition from token string starting from @typedef@ token.
30 | -- \[\text{typedef-name}=\text{ident}\]
31 | typedef :: (Integral i, Show i, Read i, Bits i) => [(HT.TokenLCNums i, HT.Token i)] -> ConstructionData i -> Either (ASTError i) ([HT.TokenLC i], ATree a, ConstructionData i)
32 | typedef ((_, HT.TKTypedef):cur@(_, HT.TKReserved _):_) _ = Left ("storage-class specifier is not allowed in this context", cur)
33 | typedef (cur@(_, HT.TKTypedef):xs) !scp = case takeType xs scp of
34 | Left er -> Left er
35 | Right (ty, Just ident, ds, scp') -> case ds of
36 | (_, HT.TKReserved ";"):ds' -> do
37 | ty' <- maybeToRight ("incomplete type typedef", ident) (incomplete ty scp')
38 | (ds', ATEmpty,) <$> addTypedef ty' ident scp'
39 | _ -> Left ("expected ';' token after '" <> tshow (snd ident) <> "'", ident)
40 | Right (_, Nothing, ds, scp') -> case ds of
41 | (_, HT.TKReserved ";"):ds' -> Right (ds', ATEmpty, pushWarn "useless type name in empty declaration" cur scp')
42 | _ -> Left $ if not (null ds) then ("expected ';' token after '" <> tshow (snd $ head ds) <> "'", head ds) else ("expected ';' token", HT.emptyToken)
43 | typedef _ _ = Left (internalCE, HT.emptyToken)
44 |
45 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/Utils.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Parser.Utils
3 | Description : Data types and type synonyms used during AST construction
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Data types and type synonyms used during AST construction
11 | -}
12 | module Htcc.Parser.Utils (
13 | module Htcc.Parser.Utils.Core
14 | ) where
15 |
16 | import Htcc.Parser.Utils.Core
17 |
--------------------------------------------------------------------------------
/src/Htcc/Parser/Utils/Core.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables #-}
2 | {-|
3 | Module : Htcc.Parser.Utils.Core
4 | Description : The AST data type and its utilities
5 | Copyright : (c) roki, 2019
6 | License : MIT
7 | Maintainer : falgon53@yahoo.co.jp
8 | Stability : experimental
9 | Portability : POSIX
10 |
11 | The utilities of parsing
12 | -}
13 | module Htcc.Parser.Utils.Core (
14 | -- * General utilities of parser
15 | expectedMessage,
16 | -- * Utilities of the token
17 | takeBrace,
18 | takeExps
19 | ) where
20 |
21 | import qualified Data.Text as T
22 | import Data.Tuple.Extra (first)
23 |
24 | import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError)
25 | import qualified Htcc.Tokenizer.Token as HT
26 | import Htcc.Utils (lastInit,
27 | maybe', tshow)
28 |
29 | -- | "expected" error message
30 | expectedMessage :: Show i => T.Text -> HT.TokenLC i -> [HT.TokenLC i] -> ASTError i
31 | expectedMessage x t xs
32 | | length xs > 1 = ("expected '" <> x <> "' token before '" <> tshow (snd (xs !! 1)) <> "'", head xs)
33 | | otherwise = ("expected '" <> x <> "' token", if null xs then t else head xs)
34 |
35 | -- | Extract the partial token enclosed in parentheses from the token sequence. If it is invalid, `takeBrace` returns @(i, Text)@ indicating the error location.
36 | -- Otherwise, `takeBrace` returns a partial token enclosed in parentheses and subsequent tokens.
37 | takeBrace :: forall i. (Integral i, Read i, Show i) => T.Text -> T.Text -> [HT.TokenLC i] -> Maybe (Either (HT.TokenLC i) ([HT.TokenLC i], [HT.TokenLC i]))
38 | takeBrace leftb rightb xxs@((_, HT.TKReserved y):_)
39 | | y == leftb = Just $ f 0 0 xxs
40 | | otherwise = Nothing
41 | where
42 | f :: Int -> Int -> [HT.TokenLC i] -> Either (HT.TokenLC i) ([HT.TokenLC i], [HT.TokenLC i])
43 | f !l !r []
44 | | l /= r = Left $ head xxs
45 | | otherwise = Right ([], [])
46 | f !l !r (c@(p, HT.TKReserved x):xs')
47 | | x == rightb = if l == succ r then Right ([c], xs') else g l (succ r) xs'
48 | | x == leftb = if succ l == r then Right ([c], xs') else g (succ l) r xs'
49 | | otherwise = g l r xs'
50 | where
51 | g = (.) (fmap (first ((p, HT.TKReserved x):)) .) . f
52 | f !l !r ((p, x):xs') = first ((:) (p, x)) <$> f l r xs'
53 | takeBrace _ _ _ = Nothing
54 |
55 | -- | Get an argument from list of `Htcc.Tokenizer.Token` (e.g: Given the token of @f(g(a, b)), 42@, return the token of @f(g(a, b))@).
56 | readFn :: Eq i => [HT.TokenLC i] -> Maybe ([HT.TokenLC i], [HT.TokenLC i])
57 | readFn = readFn' 0 (0 :: Int)
58 | where
59 | readFn' !li !ri (cur@(_, HT.TKReserved ","):xs)
60 | | li == ri = Just ([], xs)
61 | | otherwise = first (cur:) <$> readFn' li ri xs
62 | readFn' !li !ri (cur@(_, HT.TKReserved ")"):xs)
63 | | li == ri = Just ([], xs)
64 | | otherwise = first (cur:) <$> readFn' li (succ ri) xs
65 | readFn' !li !ri (cur@(_, HT.TKReserved "("):xs) = first (cur:) <$> readFn' (succ li) ri xs
66 | readFn' !li !ri []
67 | | li == ri = Just ([], [])
68 | | otherwise = Nothing
69 | readFn' !li !ri (x:xs) = first (x:) <$> readFn' li ri xs
70 |
71 | -- | Get arguments from list of `Htcc.Tokenizer.Token` (e.g: Given the token of @f(f(g(a, b)), 42);@,
72 | -- return expressions that are the token of "f(g(a, b))" and the token of "42".
73 | takeExps :: Eq i => [HT.TokenLC i] -> Maybe [[HT.TokenLC i]]
74 | takeExps ((_, HT.TKReserved "("):xs) = maybe' Nothing (lastInit ((==HT.TKReserved ")") . snd) xs) $ fmap (filter (not . null)) . f
75 | where
76 | f [] = Just []
77 | f args = maybe Nothing (\(ex, ds) -> (ex:) <$> f ds) $ readFn args
78 | takeExps _ = Nothing
79 |
80 |
--------------------------------------------------------------------------------
/src/Htcc/Tokenizer.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Tokenizer
3 | Description : Tokenizer
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The tokenizer
11 | -}
12 | module Htcc.Tokenizer (
13 | module Htcc.Tokenizer.Token,
14 | tokenize
15 | ) where
16 |
17 | import Control.Monad ((>=>))
18 | import qualified Data.Text as T
19 |
20 | import Htcc.CRules.Preprocessor as CP
21 | import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError)
22 | import Htcc.Tokenizer.Core (tokenize')
23 | import Htcc.Tokenizer.Token
24 |
25 | -- | Tokenize the `T.Text`. If an invalid chraracter matches as C language, the part and the character are returned.
26 | -- Otherwise, @[TokenIdx i]@ is returned.
27 | tokenize :: (Integral i, Read i, Show i) => T.Text -> Either (ASTError i) [TokenLC i]
28 | tokenize = tokenize' >=> CP.preprocess
29 |
--------------------------------------------------------------------------------
/src/Htcc/Tokenizer/Core.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Tokenizer.Core
3 | Description : Tokenizer
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | The tokenizer
11 | -}
12 | {-# LANGUAGE LambdaCase, MultiWayIf, OverloadedStrings, TupleSections #-}
13 | module Htcc.Tokenizer.Core (
14 | -- * Tokenizer
15 | tokenize'
16 | ) where
17 |
18 | import Control.Applicative (Alternative (..))
19 | import Control.Conditional (ifM)
20 | import Control.Monad.Extra (firstJustM)
21 | import Control.Monad.State
22 | import Data.Char (digitToInt,
23 | isDigit, ord)
24 | import Data.List (find)
25 | import Data.Maybe (fromJust,
26 | isJust,
27 | isNothing)
28 | import qualified Data.Text as T
29 | import qualified Data.Text.Encoding as T
30 | import Numeric (readHex,
31 | showHex)
32 |
33 | import qualified Htcc.CRules as CR
34 | import qualified Htcc.CRules.Preprocessor.Punctuators as CP
35 | import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError)
36 | import Htcc.Tokenizer.Token
37 | import Htcc.Utils (isStrictSpace,
38 | lor, maybe',
39 | spanLenT,
40 | subTextIndex,
41 | tshow)
42 | import qualified Htcc.Utils.CompilationState as C
43 |
44 |
45 | {-# INLINE isNewLine #-}
46 | isNewLine :: Char -> Bool
47 | isNewLine = lor [(=='\n'), (=='\r')]
48 |
49 | {-# INLINE headToken #-}
50 | headToken :: (Char -> Token i) -> T.Text -> Token i
51 | headToken f txt
52 | | T.null txt = TKEmpty
53 | | otherwise = f $ T.head txt
54 |
55 | type Tokenizer i a = C.CompilationState (TokenLCNums i) T.Text i a
56 |
57 | {-# INLINE advanceLC #-}
58 | advanceLC :: (Enum i, Num i) => TokenLCNums i -> Char -> TokenLCNums i
59 | advanceLC lc e
60 | | isNewLine e = lc { tkCn = 1, tkLn = succ $ tkLn lc }
61 | | otherwise = lc { tkCn = succ $ tkCn lc }
62 |
63 | {-# INLINE itemP #-}
64 | itemP :: Tokenizer i (Maybe Char)
65 | itemP = C.itemP
66 |
67 | {-# INLINE itemC #-}
68 | itemC :: (Enum i, Num i) => Tokenizer i (Maybe Char)
69 | itemC = C.itemC advanceLC
70 |
71 | {-# INLINE itemsP #-}
72 | itemsP :: Int -> Tokenizer i (Maybe T.Text)
73 | itemsP = C.itemsP
74 |
75 | {-# INLINE curLC #-}
76 | curLC :: Tokenizer i (TokenLCNums i)
77 | curLC = C.curCD
78 |
79 | char :: (Enum i, Num i) => (Char -> Bool) -> Tokenizer i (Maybe Char)
80 | char = C.itemCWhen advanceLC
81 |
82 | string :: (Enum i, Num i) => (Char -> Bool) -> Tokenizer i T.Text
83 | string = C.itemsCWhen advanceLC
84 |
85 | isPrefixOf :: Enum i => T.Text -> Tokenizer i Bool
86 | isPrefixOf = C.isSatisfied . T.isPrefixOf
87 |
88 | consumeSpace :: (Enum i, Num i) => Tokenizer i Bool
89 | consumeSpace = not . T.null <$> string isStrictSpace
90 |
91 | consumeNewLine :: (Enum i, Num i) => Tokenizer i Bool
92 | consumeNewLine = not . T.null <$> string isNewLine
93 |
94 | consumeComment :: (Enum i, Num i) => Tokenizer i Bool
95 | consumeComment = ifM (isPrefixOf "//") (True <$ line) $ flip (ifM (isPrefixOf "/*")) (return False) $ do
96 | cur <- curLC
97 | replicateM_ 2 itemC
98 | ind <- gets (subTextIndex "*/" . snd)
99 | True <$ maybe' (lift $ Left ("unterminated comment, expected to '*/'", (cur, TKReserved "/"))) ind (flip replicateM_ itemC . (+2))
100 |
101 | line :: (Enum i, Num i) => Tokenizer i T.Text
102 | line = string (not . isNewLine)
103 |
104 | macro :: (Enum i, Num i) => Tokenizer i (Maybe (Token i))
105 | macro = ifM ((/= Just '#') <$> itemP) (return Nothing) f
106 | where
107 | f = (>>=) itemC $ maybe (return Nothing) $ \case
108 | '#' -> do
109 | cur <- curLC
110 | ln <- line
111 | if T.null ln then return Nothing else let (_, kmc, ds) = spanLenT CR.isValidChar ln in
112 | maybe' (lift $ Left ("invalid macro in program", (cur, TKReserved ln))) (find ((==kmc) . tshow) CP.macros) $ \m -> return $ Just $ TKMacro m ds
113 | _ -> return Nothing
114 |
115 | natLit :: (Enum i, Num i, Eq i, Read i) => Tokenizer i (Maybe (Token i))
116 | natLit = do
117 | lc <- gets fst
118 | ifM (maybe True (not . isDigit) <$> itemP) (return Nothing) $ do
119 | txt <- gets snd
120 | maybe' (lift $ Left ("invalid number in program", (lc, headToken (TKNum . fromIntegral . digitToInt) txt))) (spanIntLit txt) $ \(n, tk, ds) ->
121 | Just tk <$ put (lc { tkCn = tkCn lc + fromIntegral n }, ds)
122 |
123 | strLit :: (Enum i, Num i) => Tokenizer i (Maybe (Token i))
124 | strLit = do
125 | lc <- gets fst
126 | ifM (isNothing <$> char (=='\"')) (return Nothing) $ do
127 | txt <- gets snd
128 | maybe' (lift $ Left ("invalid string literal in program", (lc, TKReserved "\""))) (spanStrLiteral txt) $ \(lit, ds) ->
129 | -- The meaning of adding 2 is to add the two "characters surrounding the string literal.
130 | Just (TKString (T.encodeUtf8 $ T.append lit "\0")) <$ put (lc { tkCn = 2 + tkCn lc + fromIntegral (T.length lit) }, ds)
131 |
132 | charLit :: (Enum i, Num i, Eq i) => Tokenizer i (Maybe (Token i))
133 | charLit = do
134 | lc <- gets fst
135 | ifM (isNothing <$> char (=='\'')) (return Nothing) $ do
136 | txt <- gets snd
137 | maybe' (lift $ Left ("invalid char literal in program", (lc, TKReserved "\'"))) (spanCharLiteral txt) $ \(lit, ds) ->
138 | -- Adding 3 means to add a single character literal and two @"@
139 | if | T.length lit == 1 -> Just (TKNum (fromIntegral $ ord $ T.head lit)) <$ put (lc { tkCn = 3 + tkCn lc }, ds)
140 | -- For multi-character constants.
141 | -- The standard states that this is an implementation definition.
142 | -- Here it follows the implementation definitions of GCC and Clang.
143 | | otherwise -> Just (TKNum $ fst $ head $ readHex $ foldr (\x acc -> showHex (ord x) "" <> acc) [] $ T.unpack lit) <$
144 | put (lc { tkCn = 2 + fromIntegral (T.length lit) + tkCn lc }, ds)
145 |
146 | operators :: (Enum i, Num i) => Tokenizer i (Maybe (Token i))
147 | operators = do
148 | s3 <- itemsP 3
149 | if isJust s3 && fromJust s3 `elem` CR.strOps3 then Just (TKReserved $ fromJust s3) <$ replicateM_ 3 itemC else do
150 | s2 <- itemsP 2
151 | if isJust s2 && fromJust s2 `elem` CR.strOps2 then Just (TKReserved $ fromJust s2) <$ replicateM_ 2 itemC else do
152 | s1 <- itemP
153 | if isJust s1 && fromJust s1 `elem` CR.charOps then Just (TKReserved $ T.singleton $ fromJust s1) <$ itemC else
154 | return Nothing
155 |
156 | keyWordOrIdent :: (Enum i, Num i, Show i) => Tokenizer i (Maybe (Token i))
157 | keyWordOrIdent = do
158 | (lc, txt) <- get
159 | string CR.isValidChar >>= \s -> if T.null s then lift $ Left ("stray token in program", (lc, TKReserved $ T.takeWhile (not . CR.isValidChar) txt)) else
160 | return $ lookupKeyword s <|> Just (TKIdent s)
161 |
162 | -- | The core function of `Htcc.Tokenizer.tokenize`
163 | tokenize' :: (Enum i, Num i, Eq i, Read i, Show i) => T.Text -> Either (ASTError i) [TokenLC i]
164 | tokenize' = evalStateT runTokenizer' . (TokenLCNums 1 1,)
165 | where
166 | next = get >>= lift . evalStateT runTokenizer'
167 | runTokenizer' = foldr ((.) . (`ifM` next)) id [consumeSpace, consumeNewLine, consumeComment] $ do
168 | cur <- curLC
169 | ifM (isNothing <$> itemP) (lift $ Right []) $
170 | firstJustM id [macro, natLit, strLit, charLit, operators, keyWordOrIdent] >>= maybe (lift $ Right []) (\tk -> ((cur, tk):) <$> next)
171 |
--------------------------------------------------------------------------------
/src/Htcc/Utils.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Utils
3 | Description : Utilities
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | General-purpose utilities
11 | -}
12 | {-# LANGUAGE BangPatterns, Rank2Types, ScopedTypeVariables, TupleSections,
13 | TypeOperators #-}
14 | module Htcc.Utils (
15 | -- * Extra functions for lists
16 | module Htcc.Utils.List,
17 | -- * For Monad
18 | bothM, (*^*),
19 | -- * For Data.Maybe
20 | maybe',
21 | -- * For Char
22 | isStrictSpace,
23 | -- * For Data.Text
24 | module Htcc.Utils.Text,
25 | -- * For Numeric.Natural
26 | toNatural, toInteger,
27 | -- * For print shortcuts
28 | module Htcc.Utils.Print,
29 | -- * For triples and quadruple
30 | module Htcc.Utils.Tuple,
31 | -- * Boolean methods
32 | module Htcc.Utils.Bool,
33 | -- * Natural transformations
34 | module Htcc.Utils.NaturalTransformations,
35 | -- * For data type
36 | toInts
37 | ) where
38 |
39 | import Data.Char (isSpace)
40 | import Data.Tuple.Extra (both)
41 | import Numeric.Natural
42 | import Prelude hiding (toInteger)
43 |
44 | import Htcc.Utils.Bool
45 | import Htcc.Utils.List
46 | import Htcc.Utils.NaturalTransformations
47 | import Htcc.Utils.Print
48 | import Htcc.Utils.Text
49 | import Htcc.Utils.Tuple
50 |
51 | {-# INLINE maybe' #-}
52 | -- | `maybe'` is `maybe` with changed argument order.
53 | maybe' :: b -> Maybe a -> (a -> b) -> b
54 | maybe' n m f = maybe n f m
55 |
56 | -- | `toNatural` is a shortcut for @fromIntegral :: Integral i => i -> Natural@
57 | {-# INLINE toNatural #-}
58 | toNatural :: Integral i => i -> Natural
59 | toNatural = fromIntegral
60 |
61 | -- | `toInteger` is a shortcut for @fromIntegral :: Natural -> Integer@
62 | {-# INLINE toInteger #-}
63 | toInteger :: Natural -> Integer
64 | toInteger = fromIntegral
65 |
66 | -- | Convert the instance of `Integral` to Int. When it cause overflow, express it as a list of `Int`s divided into multiple values.
67 | -- `toInts` is useful for functions that have an `Int` type as an argument. e.g.:
68 | --
69 | -- >>> toInts (fromIntegral (maxBound :: Int) + 1 :: Integer)
70 | -- [9223372036854775807,1]
71 | -- >>> toInts (fromIntegral (maxBound :: Int) * 3 + 4 :: Integer)
72 | -- [9223372036854775807,9223372036854775807,9223372036854775807,4]
73 | toInts :: Integral i => i -> [Int]
74 | toInts !x = if xd >= 1 && xm == 0 then [fromIntegral x] else replicate xd (maxBound :: Int) ++ [xm]
75 | where
76 | (!xd, !xm) = both fromIntegral $ x `divMod` fromIntegral (maxBound :: Int)
77 |
78 | -- | `isStrictSpace` returns True only if the given string is not a linefeed code and `Data.Char.isSpace` returns `True`, otherwise returns `False`.
79 | isStrictSpace :: Char -> Bool
80 | isStrictSpace = land [(/='\n'), (/='\r'), isSpace]
81 |
82 | -- | The monadic `Data.Tuple.Extra.both`.
83 | -- e.g.:
84 | --
85 | -- >>> a <- newIORef (42 :: Int)
86 | -- >>> b <- newIORef (53 :: Int)
87 | -- >>> bothM readIORef (a, b) >>= print
88 | -- (42,53)
89 | bothM :: Monad m => (a -> m b) -> (a, a) -> m (b, b)
90 | bothM f (x, y) = do
91 | x' <- f x
92 | (x',) <$> f y
93 |
94 | infixr 3 *^*
95 |
96 | -- | The monadic `Data.Tuple.Extra.***`.
97 | -- e.g.:
98 | --
99 | -- >>> a <- newIORef 1
100 | -- >>> b <- newIORef 2
101 | -- >>> (writeIORef a *^* writeIORef b) (42, 53) >> bothM readIORef (a, b) >>= print
102 | -- (42,53)
103 | (*^*) :: Monad m => (a -> m c) -> (b -> m d) -> (a, b) -> m (c, d)
104 | (*^*) f g (x, y) = do
105 | x' <- f x
106 | (x',) <$> g y
107 |
--------------------------------------------------------------------------------
/src/Htcc/Utils/Bool.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Utils.Bool
3 | Description : Utilities of boolean
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Utilities of boolean
11 | -}
12 | {-# LANGUAGE ScopedTypeVariables #-}
13 | module Htcc.Utils.Bool (
14 | -- * Boolean methods
15 | lor,
16 | land,
17 | sop,
18 | sopText
19 | ) where
20 |
21 | import qualified Data.Text as T
22 | import Prelude hiding (toInteger)
23 |
24 | -- | For mappings \(f_i:X\to B\) to an element \(x\in X\) of a set \(X\), \(\displaystyle\bigvee_{i} f_i(x)\) where \(B\) is the boolean domain.
25 | -- This function will stop evaluation when the result of \(f_i(x)\) is `True` (short circuit evaluation).
26 | -- This is equivalent to:
27 | --
28 | -- > f1 x || f2 x || f3 x == lor [f1, f2, f3] x
29 | lor :: [a -> Bool] -> a -> Bool
30 | lor [] _ = False
31 | lor (f:fs) x | f x = True | otherwise = lor fs x
32 |
33 | -- | For mappings \(f_i:X\to B\) to an element (\x\in X\) of a set \(X\), \(\displaystyle\bigwedge_{i} f_i(x)\) where \(B\) is the boolean domain.
34 | -- This is equivalent to:
35 | --
36 | -- > f1 x && f2 x && f3 x == land [f1, f2, f3] x
37 | land :: [a -> Bool] -> a -> Bool
38 | land [] _ = False
39 | land (f:fs) x = foldr ((&&) . flip id x) (f x) fs
40 |
41 | -- | Sum of product form.
42 | -- For mappings \(f_i:X\to B\) to an element \(x\in X\) of a set \(X\), \(\displaystyle\bigwedge_{j}\bigvee_{i} f_i(x_j)\) where \(B\) is the Boolean domain.
43 | -- This function will stop evaluation when the result of \(f_i(x)\) is `True` (short circuit evaluation).
44 | sop :: [a -> Bool] -> [a] -> Bool
45 | sop = all . lor
46 |
47 | -- | The `T.Text` version of `sop`.
48 | sopText :: [Char -> Bool] -> T.Text -> Bool
49 | sopText = T.all . lor
50 |
51 |
--------------------------------------------------------------------------------
/src/Htcc/Utils/CompilationState.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Utils.CompilationState
3 | Description : Utilities
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | General-purpose utilities
11 | -}
12 | module Htcc.Utils.CompilationState (
13 | CompilationState,
14 | itemP,
15 | itemsP,
16 | itemC,
17 | itemsC,
18 | curCD,
19 | itemCWhen,
20 | itemsCWhen,
21 | isSatisfied
22 | ) where
23 |
24 | import Control.Monad (replicateM)
25 | import Control.Monad.Loops (unfoldM)
26 | import Control.Monad.State (StateT, get,
27 | gets, put)
28 | import Data.Bool (bool)
29 | import Data.Maybe (catMaybes)
30 | import Data.MonoTraversable (Element, MonoFoldable (..),
31 | headMay)
32 | import qualified Data.Sequences as S
33 | import Data.Tuple.Extra (first, second)
34 |
35 | import Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError)
36 |
37 | -- | The state type handled during compilation.
38 | -- It has informations required during the compilation process and input data consumed.
39 | type CompilationState cd inp i r = StateT (cd, inp) (Either (ASTError i)) r
40 |
41 | {-# INLINE itemP #-}
42 | -- | `itemP` peeks at one item from input data
43 | itemP :: MonoFoldable mono => CompilationState cd mono i (Maybe (Element mono))
44 | itemP = gets (headMay . snd)
45 |
46 | {-# INLINE itemsP #-}
47 | -- | `itemsP` peeks at items from input data
48 | itemsP :: (MonoFoldable mono, S.IsSequence mono) => S.Index mono -> CompilationState cd mono i (Maybe mono)
49 | itemsP n = do
50 | x <- gets (S.take n . snd)
51 | return $ if olength x == fromIntegral n then Just x else Nothing
52 |
53 | {-# INLINE itemC #-}
54 | -- | `itemC` consumes at one item from input data.
55 | -- Defines information updates by providing a function that
56 | -- accepts the current information and one item to be consumed and returns the information
57 | itemC :: S.IsSequence mono => (cd -> Element mono -> cd) -> CompilationState cd mono i (Maybe (Element mono))
58 | itemC f = itemP >>= maybe (return Nothing) (\itp -> Just itp <$ (get >>= put . first (`f` itp) . second S.tailEx))
59 |
60 | {-# INLINE itemsC #-}
61 | -- | `itemsC` consumes at items from input data.
62 | -- Defines information updates by providing a function that
63 | -- accepts the current information and one item to be consumed and returns the information
64 | itemsC :: S.IsSequence mono => (cd -> Element mono -> cd) -> Int -> CompilationState cd mono i (Maybe mono)
65 | itemsC f n = do
66 | x <- catMaybes <$> replicateM n (itemC f)
67 | return $ if length x == n then Just $ S.pack x else Nothing
68 |
69 | {-# INLINE curCD #-}
70 | -- | `curCD` gets current information
71 | curCD :: CompilationState cd mono i cd
72 | curCD = gets fst
73 |
74 | {-# INLINE itemCWhen #-}
75 | -- | `itemCWhen` consumes an item when the unary function satisfies the given condition.
76 | -- Defines information updates by providing a function that
77 | -- accepts the current information and one item to be consumed and returns the information
78 | itemCWhen :: (MonoFoldable mono, S.IsSequence mono) => (cd -> Element mono -> cd) -> (Element mono -> Bool) -> CompilationState cd mono i (Maybe (Element mono))
79 | itemCWhen cf f = itemP >>= maybe (return Nothing) (bool (return Nothing) (itemC cf) . f)
80 |
81 | {-# INLINE itemsCWhen #-}
82 | -- | `itemsCWhen` consumes items when the unary function satisfies the given condition.
83 | -- Defines information updates by providing a function that
84 | -- accepts the current information and one item to be consumed and returns the information
85 | itemsCWhen :: (MonoFoldable mono, S.IsSequence mono) => (cd -> Element mono -> cd) -> (Element mono -> Bool) -> CompilationState cd mono i mono
86 | itemsCWhen cf f = fmap S.pack $ unfoldM $ itemCWhen cf f
87 |
88 | {-# INLINE isSatisfied #-}
89 | -- | `isSatisfied` returns `True` if the input data satisfies the condition of given unary function, otherwise returns `False`.
90 | isSatisfied :: (mono -> Bool) -> CompilationState cd mono i Bool
91 | isSatisfied f = gets (f . snd)
92 |
93 |
--------------------------------------------------------------------------------
/src/Htcc/Utils/List.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Utils.List
3 | Description : Utilities
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | List utilities
11 | -}
12 | {-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
13 | module Htcc.Utils.List (
14 | -- * Extra functions for lists
15 | takeWhileLen,
16 | splitAtLen,
17 | spanLen,
18 | lastInit
19 | ) where
20 |
21 | import Data.Tuple.Extra (second)
22 | import Htcc.Utils.Tuple
23 | import Prelude hiding (toInteger)
24 |
25 | -- | `lastInit` returns @Just (init xxs)@ when @f (last x) == True@ for then given list @xxs@.
26 | -- Otherwise, returns `Nothing`
27 | lastInit :: (a -> Bool) -> [a] -> Maybe [a]
28 | lastInit _ [] = Nothing
29 | lastInit f [x]
30 | | f x = Just []
31 | | otherwise = Nothing
32 | lastInit y (x:xs) = (x:) <$> lastInit y xs
33 |
34 | -- | `takeWhileLen`, applied to a predicate @f@ and a list @xs@, returns the
35 | -- longest prefix (possibly empty) of @xs@ of elements that satisfy @f@ and
36 | -- the length of the list taken. The time complexity of this function is
37 | -- equivalent to `takeWhile`.
38 | takeWhileLen :: (a -> Bool) -> [a] -> (Int, [a])
39 | takeWhileLen = takeWhileLen' 0
40 | where
41 | takeWhileLen' !n _ [] = (n, [])
42 | takeWhileLen' !n f (x:xs)
43 | | f x = second (x:) $ takeWhileLen' (succ n) f xs
44 | | otherwise = (n, [])
45 |
46 | -- | `splitAtLen`, simmilar to `splitAt` but also returns the length of the splited list.
47 | splitAtLen :: Int -> [a] -> (Int, [a], [a])
48 | splitAtLen !n = go n
49 | where
50 | go 0 xs = (n, [], xs)
51 | go !n' (x:xs) = second3 (x:) $ go (pred n') xs
52 | go !n' [] = (n - n', [], [])
53 |
54 | -- | Almost the same as `span`, but returns the number of elements in the list that
55 | -- satisfy @f@ at the same time.
56 | spanLen :: (a -> Bool) -> [a] -> (Int, [a], [a])
57 | spanLen = spanLen' 0
58 | where
59 | spanLen' !n _ [] = (n, [], [])
60 | spanLen' !n f xs@(x:xs')
61 | | f x = second3 (x:) $ spanLen' (succ n) f xs'
62 | | otherwise = (n, [], xs)
63 |
--------------------------------------------------------------------------------
/src/Htcc/Utils/NaturalTransformations.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Utils.NaturalTransformations
3 | Description : Utilities of natural transformations
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Utilities of natural transformations
11 | -}
12 | {-# LANGUAGE Rank2Types, TypeOperators #-}
13 | module Htcc.Utils.NaturalTransformations (
14 | maybeToRight
15 | ) where
16 |
17 | import Control.Natural (type (~>))
18 |
19 | -- | Natural transformation from @Maybe@ functor to @Either e@ functor
20 | maybeToRight :: e -> Maybe ~> Either e
21 | maybeToRight s Nothing = Left s
22 | maybeToRight _ (Just x) = Right x
23 |
--------------------------------------------------------------------------------
/src/Htcc/Utils/Print.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Utils.Print
3 | Description : Utilities
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Utilities of print
11 | -}
12 | {-# LANGUAGE ScopedTypeVariables #-}
13 | module Htcc.Utils.Print (
14 | -- * Shortcuts of print
15 | putStrErr, putStrLnErr, err,
16 | putDocLn, putDocErr, putDocLnErr,
17 | errTxtDoc, errCharDoc, warnTxtDoc,
18 | warnCharDoc, locTxtDoc, locCharDoc,
19 | ) where
20 |
21 | import qualified Data.Text as T
22 | import qualified Data.Text.IO as T
23 | import Prelude hiding (toInteger)
24 | import System.Exit (exitFailure)
25 | import System.IO (stderr)
26 | import Text.PrettyPrint.ANSI.Leijen (Doc, bold, char, hPutDoc,
27 | linebreak, magenta, putDoc, red,
28 | text)
29 |
30 | {-# INLINE putDocLn #-}
31 | -- | Execute `Text.PrettyPrint.ANSI.Leijen.putDoc` by applying `Text.PrettyPrint.ANSI.Leijen.linebreak`
32 | -- to `Text.PrettyPrint.ANSI.Leijen.<>` at the end of given `Text.PrettyPrint.ANSI.Leijen.Doc`
33 | putDocLn :: Doc -> IO ()
34 | putDocLn = putDoc . flip (<>) linebreak
35 |
36 | {-# INLINE putDocErr #-}
37 | -- | The shortcut of @hPutDoc stderr@
38 | putDocErr :: Doc -> IO ()
39 | putDocErr = hPutDoc stderr
40 |
41 | {-# INLINE putDocLnErr #-}
42 | -- | Execute `putDocErr` by applying `Text.PrettyPrint.ANSI.Leijen.linebreak`
43 | -- to `Text.PrettyPrint.ANSI.Leijen.<>` at the end of given `Text.PrettyPrint.ANSI.Leijen.Doc`
44 | putDocLnErr :: Doc -> IO ()
45 | putDocLnErr = putDocErr . flip (<>) linebreak
46 |
47 | {-# INLINE errTxtDoc #-}
48 | -- | The `Text.PrettyPrint.ANSI.Leijen.Doc` used to output an error message (`String`),
49 | -- it is shortcut of @red . text@
50 | errTxtDoc :: String -> Doc
51 | errTxtDoc = red . text
52 |
53 | {-# INLINE errCharDoc #-}
54 | -- | The `Text.PrettyPrint.ANSI.Leijen.Doc` used to output an error message (`Char`),
55 | -- it is shortcut of @red. char@
56 | errCharDoc :: Char -> Doc
57 | errCharDoc = red . char
58 |
59 | {-# INLINE warnTxtDoc #-}
60 | -- | The `Text.PrettyPrint.ANSI.Leijen.Doc` used to output an warning message (`String`),
61 | -- it is shortcut of @magenta . text@
62 | warnTxtDoc :: String -> Doc
63 | warnTxtDoc = magenta . text
64 |
65 | {-# INLINE warnCharDoc #-}
66 | -- | The `Text.PrettyPrint.ANSI.Leijen.Doc` used to output an warning message (`Char`),
67 | -- it is shortcut of @magenta . char@
68 | warnCharDoc :: Char -> Doc
69 | warnCharDoc = magenta . char
70 |
71 | {-# INLINE locTxtDoc #-}
72 | -- | Doc used to output a message (`String`) about the location, such as the file name and its location,
73 | -- it is shortcut of @bold . text@
74 | locTxtDoc :: String -> Doc
75 | locTxtDoc = bold . text
76 |
77 | {-# INLINE locCharDoc #-}
78 | -- | Doc used to output a message (`Char`) about the location, such as the file name and its location,
79 | -- it is shortcut of @bold . char@
80 | locCharDoc :: Char -> Doc
81 | locCharDoc = bold . char
82 |
83 | -- | Standard error output shortcut (with new line).
84 | putStrLnErr :: T.Text -> IO ()
85 | putStrLnErr = T.hPutStrLn stderr
86 |
87 | -- | Standard error output shortcut.
88 | putStrErr :: T.Text -> IO ()
89 | putStrErr = T.hPutStr stderr
90 |
91 | -- | Standard error output and exit shortcut.
92 | err :: T.Text -> IO ()
93 | err = flip (>>) exitFailure . putStrLnErr
94 |
--------------------------------------------------------------------------------
/src/Htcc/Utils/Text.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Utils.Text
3 | Description : Utilities
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Text utilities
11 | -}
12 | {-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
13 | module Htcc.Utils.Text (
14 | -- * For Data.Text
15 | tshow,
16 | spanLenT,
17 | subTextIndex
18 | ) where
19 |
20 | import qualified Data.Text as T
21 | import qualified Data.Text.Internal.Search as T
22 | import Htcc.Utils.Tuple (second3)
23 | import Prelude hiding (toInteger)
24 |
25 | {-# INLINE tshow #-}
26 | -- | Convert `Show` class instance to `Data.Text`.
27 | tshow :: Show a => a -> T.Text
28 | tshow = T.pack . show
29 |
30 | -- | `T.Text` version of the `Htcc.Utils.List.spanLen`.
31 | spanLenT :: (Char -> Bool) -> T.Text -> (Int, T.Text, T.Text)
32 | spanLenT = spanLenT' 0
33 | where
34 | spanLenT' !n f xs = case T.uncons xs of
35 | Just (x, xs')
36 | | f x -> second3 (T.cons x) $ spanLenT' (succ n) f xs'
37 | | otherwise -> (n, T.empty, xs)
38 | Nothing -> (n, T.empty, T.empty)
39 |
40 | -- | `subTextIndex` searches text for a substring of text and returns its starting position.
41 | -- If nothing is found, `Nothing` is returned.
42 | subTextIndex :: T.Text -> T.Text -> Maybe Int
43 | subTextIndex s t = case T.indices s t of
44 | (i:_) -> Just i
45 | _ -> Nothing
46 |
47 |
--------------------------------------------------------------------------------
/src/Htcc/Utils/Tuple.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Utils.Tuple
3 | Description : Utilities
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Utilities of tuple
11 | -}
12 | {-# LANGUAGE ScopedTypeVariables #-}
13 | module Htcc.Utils.Tuple (
14 | -- * For double
15 | swap,
16 | -- * For triples
17 | first3,
18 | second3,
19 | third3,
20 | dropFst3,
21 | dropSnd3,
22 | dropThd3,
23 | -- * For quadruple
24 | fst4,
25 | snd4,
26 | thd4,
27 | fou4,
28 | first4,
29 | second4,
30 | third4,
31 | fourth4,
32 | dropFst4,
33 | dropSnd4,
34 | dropThd4,
35 | dropFourth4,
36 | curry4,
37 | uncurry4,
38 | ) where
39 |
40 | import Data.Tuple.Extra (dupe, first, second)
41 |
42 | {-# INLINE swap #-}
43 | -- | Swap a first element and second element
44 | swap :: (a, b) -> (b, a)
45 | swap = first snd . second fst . dupe
46 |
47 | {-# INLINE first3 #-}
48 | -- | Update the first component of triple.
49 | first3 :: (a -> d) -> (a, b, c) -> (d, b, c)
50 | first3 f (x, y, z) = (f x, y, z)
51 |
52 | {-# INLINE second3 #-}
53 | -- | Update the second component of triple.
54 | second3 :: (b -> d) -> (a, b, c) -> (a, d, c)
55 | second3 f (x, y, z) = (x, f y, z)
56 |
57 | {-# INLINE third3 #-}
58 | -- | Update the third component of triple.
59 | third3 :: (c -> d) -> (a, b, c) -> (a, b, d)
60 | third3 f (x, y, z) = (x, y, f z)
61 |
62 | {-# INLINE dropFst3 #-}
63 | -- | Drop first element of triple and returns pair
64 | dropFst3 :: (a, b, c) -> (b, c)
65 | dropFst3 (_, y, z) = (y, z)
66 |
67 | {-# INLINE dropSnd3 #-}
68 | -- | Drop second element of triple and returns pair
69 | dropSnd3 :: (a, b, c) -> (a, c)
70 | dropSnd3 (x, _, z) = (x, z)
71 |
72 | {-# INLINE dropThd3 #-}
73 | -- | Drop third element of triple and returns pair
74 | dropThd3 :: (a, b, c) -> (a, b)
75 | dropThd3 (x, y, _) = (x, y)
76 |
77 | {-# INLINE dropFst4 #-}
78 | -- | Drop first element of quadruple.
79 | dropFst4 :: (a, b, c, d) -> (b, c, d)
80 | dropFst4 (_, b, c, d) = (b, c, d)
81 |
82 | {-# INLINE dropSnd4 #-}
83 | -- | Drop second element of quadruple.
84 | dropSnd4 :: (a, b, c, d) -> (a, c, d)
85 | dropSnd4 (a, _, c, d) = (a, c, d)
86 |
87 | {-# INLINE dropThd4 #-}
88 | -- | Drop third element of quadruple.
89 | dropThd4 :: (a, b, c, d) -> (a, b, d)
90 | dropThd4 (a, b, _, d) = (a, b, d)
91 |
92 | {-# INLINE dropFourth4 #-}
93 | -- | Drop fourth element of quadruple.
94 | dropFourth4 :: (a, b, c, d) -> (a, b, c)
95 | dropFourth4 (a, b, c, _) = (a, b, c)
96 |
97 | {-# INLINE fst4 #-}
98 | -- | Take first element of quadruple.
99 | fst4 :: (a, b, c, d) -> a
100 | fst4 (a, _, _, _) = a
101 |
102 | {-# INLINE snd4 #-}
103 | -- | Take second element of quadruple.
104 | snd4 :: (a, b, c, d) -> b
105 | snd4 (_, b, _, _) = b
106 |
107 | {-# INLINE thd4 #-}
108 | -- | Take third element of quadruple.
109 | thd4 :: (a, b, c, d) -> c
110 | thd4 (_, _, c, _) = c
111 |
112 | {-# INLINE fou4 #-}
113 | -- | Take fourth element of quadruple.
114 | fou4 :: (a, b, c, d) -> d
115 | fou4 (_, _, _, d) = d
116 |
117 | {-# INLINE first4 #-}
118 | -- | Update first component of quadruple.
119 | first4 :: (a -> e) -> (a, b, c, d) -> (e, b, c, d)
120 | first4 f (a, b, c, d) = (f a, b, c, d)
121 |
122 | {-# INLINE second4 #-}
123 | -- | Update second component of quadruple.
124 | second4 :: (b -> e) -> (a, b, c, d) -> (a, e, c, d)
125 | second4 f (a, b, c, d) = (a, f b, c, d)
126 |
127 | {-# INLINE third4 #-}
128 | -- | Update third component of quadruple.
129 | third4 :: (c -> e) -> (a, b, c, d) -> (a, b, e, d)
130 | third4 f (a, b, c, d) = (a, b, f c, d)
131 |
132 | {-# INLINE fourth4 #-}
133 | -- | Update fourth component of quadruple.
134 | fourth4 :: (d -> e) -> (a, b, c, d) -> (a, b, c, e)
135 | fourth4 f (a, b, c, d) = (a, b, c, f d)
136 |
137 | {-# INLINE curry4 #-}
138 | -- | Converts an uncurried function to a curried function.
139 | curry4 :: ((a, b, c, d) -> e) -> a -> b -> c -> d -> e
140 | curry4 f a b c d = f (a, b, c, d)
141 |
142 | {-# INLINE uncurry4 #-}
143 | -- | Converts a curried function to a function on a quadruple.
144 | uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
145 | uncurry4 f (a, b, c, d) = f a b c d
146 |
--------------------------------------------------------------------------------
/src/Htcc/Visualizer.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Visualizer
3 | Description : Build AST from C source code
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Build AST from C source code
11 | -}
12 | module Htcc.Visualizer (
13 | module Htcc.Visualizer.Core
14 | ) where
15 |
16 | import Htcc.Visualizer.Core
17 |
--------------------------------------------------------------------------------
/src/Htcc/Visualizer/Core.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module : Htcc.Visualizer.Core
3 | Description : Build AST from C source code
4 | Copyright : (c) roki, 2019
5 | License : MIT
6 | Maintainer : falgon53@yahoo.co.jp
7 | Stability : experimental
8 | Portability : POSIX
9 |
10 | Build AST from C source code
11 | -}
12 | {-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
13 | module Htcc.Visualizer.Core (
14 | visualize
15 | ) where
16 |
17 | import qualified Data.Text as T
18 | import Data.Tree (Tree (..))
19 | import Diagrams.Backend.SVG (SVG, renderPretty)
20 | import Diagrams.Prelude
21 | import Diagrams.TwoD.Layout.Tree (renderTree, slHSep, slVSep,
22 | symmLayout')
23 |
24 | import Htcc.CRules.Types as CT
25 | import Htcc.Parser (ASTs)
26 | import Htcc.Parser.AST.Core (ATKind (..), ATree (..),
27 | fromATKindFor)
28 | import Htcc.Utils (putStrLnErr)
29 |
30 | -- | the function to convert `ATree` to `Data.Tree`
31 | encodeTree :: Show i => ATree i -> Tree String
32 | encodeTree ATEmpty = Node "Null" []
33 | encodeTree (ATNode ATAdd _ l r) = Node "+" [encodeTree l, encodeTree r]
34 | encodeTree (ATNode ATAddPtr _ l r) = Node "+" [encodeTree l, encodeTree r]
35 | encodeTree (ATNode ATSub _ l r) = Node "-" [encodeTree l, encodeTree r]
36 | encodeTree (ATNode ATSubPtr _ l r) = Node "-" [encodeTree l, encodeTree r]
37 | encodeTree (ATNode ATPtrDis _ l r) = Node "-" [encodeTree l, encodeTree r]
38 | encodeTree (ATNode ATMul _ l r) = Node "*" [encodeTree l, encodeTree r]
39 | encodeTree (ATNode ATDiv _ l r) = Node "/" [encodeTree l, encodeTree r]
40 | encodeTree (ATNode ATMod _ l r) = Node "%" [encodeTree l, encodeTree r]
41 | encodeTree (ATNode ATAddAssign _ l r) = Node "+=" [encodeTree l, encodeTree r]
42 | encodeTree (ATNode ATSubAssign _ l r) = Node "-=" [encodeTree l, encodeTree r]
43 | encodeTree (ATNode ATMulAssign _ l r) = Node "*=" [encodeTree l, encodeTree r]
44 | encodeTree (ATNode ATDivAssign _ l r) = Node "/=" [encodeTree l, encodeTree r]
45 | encodeTree (ATNode ATAddPtrAssign _ l r) = Node "+=" [encodeTree l, encodeTree r]
46 | encodeTree (ATNode ATSubPtrAssign _ l r) = Node "-=" [encodeTree l, encodeTree r]
47 | encodeTree (ATNode ATLAnd _ l r) = Node "&&" [encodeTree l, encodeTree r]
48 | encodeTree (ATNode ATLOr _ l r) = Node "||" [encodeTree l, encodeTree r]
49 | encodeTree (ATNode ATAnd _ l r) = Node "&" [encodeTree l, encodeTree r]
50 | encodeTree (ATNode ATAndAssign _ l r) = Node "&=" [encodeTree l, encodeTree r]
51 | encodeTree (ATNode ATOr _ l r) = Node "|" [encodeTree l, encodeTree r]
52 | encodeTree (ATNode ATOrAssign _ l r) = Node "|=" [encodeTree l, encodeTree r]
53 | encodeTree (ATNode ATXor _ l r) = Node "^" [encodeTree l, encodeTree r]
54 | encodeTree (ATNode ATXorAssign _ l r) = Node "^=" [encodeTree l, encodeTree r]
55 | encodeTree (ATNode ATBitNot _ l r) = Node "~" [encodeTree l, encodeTree r]
56 | encodeTree (ATNode ATShl _ l r) = Node "<<" [encodeTree l, encodeTree r]
57 | encodeTree (ATNode ATShlAssign _ l r) = Node "<<=" [encodeTree l, encodeTree r]
58 | encodeTree (ATNode ATShr _ l r) = Node ">>" [encodeTree l, encodeTree r]
59 | encodeTree (ATNode ATShrAssign _ l r) = Node ">>=" [encodeTree l, encodeTree r]
60 | encodeTree (ATNode ATLT _ l r) = Node "<" [encodeTree l, encodeTree r]
61 | encodeTree (ATNode ATLEQ _ l r) = Node "<=" [encodeTree l, encodeTree r]
62 | encodeTree (ATNode ATGT _ l r) = Node ">" [encodeTree l, encodeTree r]
63 | encodeTree (ATNode ATGEQ _ l r) = Node ">=" [encodeTree l, encodeTree r]
64 | encodeTree (ATNode ATEQ _ l r) = Node "==" [encodeTree l, encodeTree r]
65 | encodeTree (ATNode ATNEQ _ l r) = Node "!=" [encodeTree l, encodeTree r]
66 | encodeTree (ATNode ATNot _ l _) = Node "!" [encodeTree l]
67 | encodeTree (ATNode ATAddr _ l _) = Node "&" [encodeTree l]
68 | encodeTree (ATNode ATDeref _ l _) = Node "*" [encodeTree l]
69 | encodeTree (ATNode ATAssign _ l r) = Node "=" [encodeTree l, encodeTree r]
70 | encodeTree (ATNode ATPreInc _ l r) = Node "++ (pre)" [encodeTree l, encodeTree r]
71 | encodeTree (ATNode ATPreDec _ l r) = Node "-- (pre)" [encodeTree l, encodeTree r]
72 | encodeTree (ATNode ATPostInc _ l r) = Node "++ (post)" [encodeTree l, encodeTree r]
73 | encodeTree (ATNode ATPostDec _ l r) = Node "-- (post)" [encodeTree l, encodeTree r]
74 | encodeTree (ATNode (ATNum n) t l r) = Node (show n ++ " (" ++ show (CT.toTypeKind t) ++ ")") [encodeTree l, encodeTree r]
75 | encodeTree (ATNode (ATConditional a b c) _ _ _) = Node "?:" [encodeTree a, encodeTree b, encodeTree c]
76 | encodeTree (ATNode ATComma _ l r) = Node "," [encodeTree l, encodeTree r]
77 | encodeTree (ATNode ATCast t l _) = Node ("(" ++ show (CT.toTypeKind t) ++ ")\n(type cast)") [encodeTree l]
78 | encodeTree (ATNode (ATMemberAcc _) _ l r) = Node "." [encodeTree l, encodeTree r]
79 | encodeTree (ATNode ATReturn _ l r) = Node "return" [encodeTree l, encodeTree r]
80 | encodeTree (ATNode ATIf _ l r) = Node "if" [encodeTree l, encodeTree r]
81 | encodeTree (ATNode ATElse _ l r) = Node "else" [encodeTree l, encodeTree r]
82 | encodeTree (ATNode (ATSwitch th xs) _ l r) = Node "switch" $ encodeTree th : map encodeTree xs ++ [encodeTree l, encodeTree r]
83 | encodeTree (ATNode (ATCase _ v) _ l r) = Node ("case " ++ show v) [encodeTree l, encodeTree r]
84 | encodeTree (ATNode (ATDefault _) _ l r) = Node "default" [encodeTree l, encodeTree r]
85 | encodeTree (ATNode ATWhile _ l r) = Node "while" [encodeTree l, encodeTree r]
86 | encodeTree (ATNode (ATFor atf) _ l r) = Node "for" $ map (encodeTree . fromATKindFor) atf ++ [encodeTree l, encodeTree r]
87 | encodeTree (ATNode ATBreak _ l r) = Node "break" [encodeTree l, encodeTree r]
88 | encodeTree (ATNode ATContinue _ l r) = Node "continue" [encodeTree l, encodeTree r]
89 | encodeTree (ATNode (ATGoto lbl) _ l r) = Node ("goto " ++ T.unpack lbl) [encodeTree l, encodeTree r]
90 | encodeTree (ATNode (ATLabel lbl) _ l r) = Node (":" ++ T.unpack lbl) [encodeTree l, encodeTree r]
91 | encodeTree (ATNode (ATBlock xs) _ _ _) = Node "{}" $ map encodeTree xs
92 | encodeTree (ATNode (ATLVar t o) _ l r) = Node (show t ++ " lvar" ++ show o) [encodeTree l, encodeTree r]
93 | encodeTree (ATNode (ATGVar t n) _ l r) = Node (show t ++ " " ++ T.unpack n) [encodeTree l, encodeTree r]
94 | encodeTree (ATNode (ATDefFunc fname Nothing) t lhs _) = Node (show (CT.toTypeKind t) ++ " " ++ T.unpack fname ++ "()") [encodeTree lhs]
95 | encodeTree (ATNode (ATDefFunc fname (Just args)) t lhs _) = Node (show (CT.toTypeKind t) ++ " " ++ T.unpack fname ++ "(some arguments)") $ map encodeTree args ++ [encodeTree lhs]
96 | encodeTree (ATNode (ATCallFunc fname Nothing) _ lhs rhs) = Node (T.unpack fname ++ "()") [encodeTree lhs, encodeTree rhs]
97 | encodeTree (ATNode (ATCallFunc fname (Just args)) _ lhs rhs) = Node (T.unpack fname ++ "(some arguments)") $ map encodeTree args ++ [encodeTree lhs, encodeTree rhs]
98 | encodeTree (ATNode ATExprStmt _ lhs _) = encodeTree lhs
99 | encodeTree (ATNode (ATStmtExpr exps) _ lhs rhs) = Node "({})" $ map encodeTree exps ++ [encodeTree lhs, encodeTree rhs]
100 | encodeTree (ATNode (ATNull _) _ _ _) = Node "" []
101 |
102 | renderNTree :: Tree String -> QDiagram SVG V2 Double Any
103 | renderNTree nt = renderTree
104 | (\a -> letter a `atop` circle 2.5 # fc white)
105 | (~~)
106 | (symmLayout' (with & slHSep .~ 6 & slVSep .~ 6) nt)
107 | where
108 | letter a = text a # font "monospace" # fontSize (local 0.7)
109 |
110 | -- | Build AST from C source code
111 | visualize :: Show i => ASTs i -> SizeSpec V2 Double -> FilePath -> IO ()
112 | visualize ast ss fpath = let et = map encodeTree ast in if not (null et) then
113 | renderPretty fpath ss (foldr ((|||) . renderNTree) (renderNTree $ head et) $ tail et) else
114 | putStrLnErr "There is nothing to describe"
115 |
--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
1 | resolver: lts-16.13
2 | # User packages to be built.
3 | # Various formats can be used as shown in the example below.
4 | #
5 | # packages:
6 | # - some-directory
7 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz
8 | # - location:
9 | # git: https://github.com/commercialhaskell/stack.git
10 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
11 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
12 | # subdirs:
13 | # - auto-update
14 | # - wai
15 | packages:
16 | - .
17 | # Dependency packages to be pulled from upstream that are not in the resolver
18 | # using the same syntax as the packages field.
19 | # (e.g., acme-missiles-0.3)
20 | extra-deps:
21 | - monad-finally-0.1.2@sha256:7f2c860c39d0a00908d83ddaf9cd232d09c19934381b011ed361335715b4e52e
22 | - monad-abort-fd-0.7@sha256:dc917e7ee2ec0b4f20d6e1cc323bef03adf5b2067619b6e7f4f324a50ae6e870,1340
23 | - transformers-abort-0.6.0.3@sha256:34de32cc6e852df10ad57df34e46404f841c6b0123526b7fd942c455f62a7a31,1236
24 |
25 |
26 | # Override default flag values for local packages and extra-deps
27 | # flags: {}
28 |
29 | # Extra package databases containing global packages
30 | # extra-package-dbs: []
31 |
32 | # Control whether we use the GHC we find on the path
33 | system-ghc: false
34 | #
35 | # Require a specific version of stack, using version ranges
36 | # require-stack-version: -any # Default
37 | # require-stack-version: ">=1.9"
38 | #
39 | # Override the architecture used by stack, especially useful on Windows
40 | # arch: i386
41 | # arch: x86_64
42 | #
43 | # Extra directories used by stack for building
44 | # extra-include-dirs: [/path/to/dir]
45 | # Allow a newer minor version of GHC than the snapshot specifies
46 | # compiler-check: newer-minor
47 |
48 | build:
49 | haddock: false
50 | haddock-arguments:
51 | haddock-args:
52 | - --odir=docs
53 | open-haddocks: false
54 | haddock-internal: false
55 | haddock-hyperlink-source: true
56 |
--------------------------------------------------------------------------------
/stack.yaml.lock:
--------------------------------------------------------------------------------
1 | # This file was autogenerated by Stack.
2 | # You should not edit this file by hand.
3 | # For more information, please see the documentation at:
4 | # https://docs.haskellstack.org/en/stable/lock_files
5 |
6 | packages:
7 | - completed:
8 | hackage: monad-finally-0.1.2@sha256:7f2c860c39d0a00908d83ddaf9cd232d09c19934381b011ed361335715b4e52e,1487
9 | pantry-tree:
10 | size: 347
11 | sha256: 24d7ac7af5b7d8c23bfe3eced368c3fe9ae2de5766522605ef963cd2f466dce1
12 | original:
13 | hackage: monad-finally-0.1.2@sha256:7f2c860c39d0a00908d83ddaf9cd232d09c19934381b011ed361335715b4e52e
14 | - completed:
15 | hackage: monad-abort-fd-0.7@sha256:dc917e7ee2ec0b4f20d6e1cc323bef03adf5b2067619b6e7f4f324a50ae6e870,1340
16 | pantry-tree:
17 | size: 486
18 | sha256: 8aae8657f16cd20d32307b6e815ab3b53bcd6a35e770dbe96064a3b6a5a06b6d
19 | original:
20 | hackage: monad-abort-fd-0.7@sha256:dc917e7ee2ec0b4f20d6e1cc323bef03adf5b2067619b6e7f4f324a50ae6e870,1340
21 | - completed:
22 | hackage: transformers-abort-0.6.0.3@sha256:34de32cc6e852df10ad57df34e46404f841c6b0123526b7fd942c455f62a7a31,1236
23 | pantry-tree:
24 | size: 357
25 | sha256: eeafa773cab79ad314b113aaa6e182e4a353bc1843b759241c1e761ebc1f453e
26 | original:
27 | hackage: transformers-abort-0.6.0.3@sha256:34de32cc6e852df10ad57df34e46404f841c6b0123526b7fd942c455f62a7a31,1236
28 | snapshots:
29 | - completed:
30 | size: 532381
31 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/13.yaml
32 | sha256: 6ee17f7996e5bc75ae4406250841f1362ad4196418a4d90a0615ff4f26ac98df
33 | original: lts-16.13
34 |
--------------------------------------------------------------------------------
/test/Spec.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Main where
3 |
4 | import Codec.Binary.UTF8.String (decodeString)
5 | import Control.Exception (finally)
6 | import qualified Data.ByteString.Char8 as B
7 | import qualified Data.Text as T
8 | import qualified Data.Text.IO as T
9 | import Dhall.JSON (omitNull)
10 | import Dhall.Yaml (Options (..), defaultOptions,
11 | dhallToYaml)
12 | import qualified Options.Applicative as OA
13 | import System.Directory (createDirectoryIfMissing)
14 | import System.FilePath ((>))
15 | import System.Process (readCreateProcess, shell)
16 | import qualified Tests.SubProcTests as SubProcTests
17 | import Tests.Utils
18 |
19 | workDir :: FilePath
20 | workDir = "/tmp" > "htcc"
21 |
22 | specPath :: FilePath
23 | specPath = workDir > "spec.s"
24 |
25 | dockerComposePath :: FilePath
26 | dockerComposePath = "./docker" > "test.dhall"
27 |
28 | data Command = WithSubProc | WithDocker | WithSelf
29 |
30 | data Opts = Opts
31 | { optClean :: !Bool
32 | , optCmd :: !Command
33 | }
34 |
35 | subProcCmd :: OA.Mod OA.CommandFields Command
36 | subProcCmd = OA.command "subp" $
37 | OA.info (pure WithSubProc) $ OA.progDesc "run tests with subprocess"
38 |
39 | dockerCmd :: OA.Mod OA.CommandFields Command
40 | dockerCmd = OA.command "docker" $
41 | OA.info (pure WithDocker) $ OA.progDesc "run tests in docker container"
42 |
43 | selfCmd :: OA.Mod OA.CommandFields Command
44 | selfCmd = OA.command "self" $
45 | OA.info (pure WithSelf) $ OA.progDesc "run the test using htcc's processing power"
46 |
47 | cleanOpt :: OA.Parser Bool
48 | cleanOpt = OA.switch $ mconcat [
49 | OA.long "clean"
50 | , OA.help "clean the docker container"
51 | ]
52 |
53 | programOptions :: OA.Parser Opts
54 | programOptions = Opts
55 | <$> cleanOpt
56 | <*> OA.hsubparser (mconcat [
57 | subProcCmd
58 | , dockerCmd
59 | , selfCmd
60 | ])
61 |
62 | optsParser :: OA.ParserInfo Opts
63 | optsParser = OA.info (OA.helper <*> programOptions) $ mconcat [
64 | OA.fullDesc
65 | , OA.progDesc $ "The htcc unit tester"
66 | ]
67 |
68 | genTestAsm :: IO ()
69 | genTestAsm = do
70 | createDirectoryIfMissing False workDir
71 | execErrFin $ "stack exec htcc -- " <> T.pack testCoreFile <> " > " <> T.pack specPath
72 | where
73 | testCoreFile = "./test" > "Tests" > "csrc" > "test_core.c"
74 |
75 | createProcessDhallDocker :: FilePath -> String -> IO ()
76 | createProcessDhallDocker fp cmd = T.readFile fp
77 | >>= dhallToYaml (defaultOptions { explain = True, omission = omitNull }) (Just fp)
78 | >>= readCreateProcess (shell $ "docker-compose -f - " <> cmd) . decodeString . B.unpack
79 | >>= putStrLn
80 |
81 | main :: IO ()
82 | main = do
83 | opts <- OA.execParser optsParser
84 | case optCmd opts of
85 | WithSubProc -> SubProcTests.exec
86 | WithDocker -> let runDhallDocker = createProcessDhallDocker dockerComposePath in
87 | if optClean opts then
88 | runDhallDocker "down --rmi all"
89 | else
90 | flip finally (clean [workDir]) $
91 | genTestAsm >> runDhallDocker "up --build"
92 | WithSelf -> flip finally (clean [workDir, "spec"]) $ do
93 | genTestAsm
94 | execErrFin $ "gcc -no-pie -o spec " <> T.pack specPath
95 | execErrFin "./spec"
96 |
--------------------------------------------------------------------------------
/test/Tests/Test1.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Tests.Test1 (
3 | test
4 | ) where
5 |
6 | import Control.Exception (finally)
7 | import qualified Data.Text as T
8 | import Tests.Utils
9 |
10 | test :: String -> IO (Int, String)
11 | test x = flip finally (clean ["tmp"]) $ do
12 | execErrFin $ "echo '" <> T.pack x <> "' | stack exec htcc -- /dev/stdin | gcc -no-pie -xassembler -o tmp -"
13 | exec "./tmp" >>= exitCode (\ec -> (ec, x) <$ (putStr x *> putStrLn ": [Processing]")) (return (0, x))
14 |
--------------------------------------------------------------------------------
/test/Tests/Test2.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings, TupleSections #-}
2 | module Tests.Test2 (
3 | test
4 | ) where
5 |
6 | import Control.Exception (finally)
7 | import Control.Monad (forM_)
8 | import qualified Data.Text as T
9 | import Tests.Utils
10 |
11 | test :: String -> [String] -> IO (Int, String)
12 | test x fnames = let obj = map (++".o") fnames in
13 | flip finally (clean $ ["tmp", "tmp.s"] ++ obj) $ do
14 | execErrFin $ "echo \'" <> T.pack x <> "\' | stack exec htcc -- /dev/stdin > tmp.s"
15 | forM_ fnames $ \fname -> execErrFin $ "cc -c test/Tests/csrc/" <> T.pack fname <> ".c"
16 | execErrFin $ "gcc " <> T.pack (unwords obj) <> " tmp.s -o tmp"
17 | exitCode (,x) (0, x) <$> exec "./tmp"
18 |
--------------------------------------------------------------------------------
/test/Tests/Test3.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings, TupleSections #-}
2 | module Tests.Test3 (
3 | test
4 | ) where
5 |
6 | import Control.Exception (finally)
7 | import Control.Monad (forM_)
8 | import qualified Data.Text as T
9 | import Tests.Utils
10 |
11 | -- | `test` performs a test by comparison with the standard output string.
12 | test :: String -> [String] -> IO (Either T.Text T.Text, String)
13 | test x fnames = let obj = map (++".o") fnames in
14 | flip finally (clean $ ["tmp", "tmp.s"] ++ obj) $ do
15 | execErrFin $ "echo \'" <> T.pack x <> "\' | stack exec htcc -- /dev/stdin > tmp.s"
16 | forM_ fnames $ \fname -> execErrFin $ "cc -c test/Tests/csrc/" <> T.pack fname <> ".c"
17 | execErrFin $ "gcc " <> T.pack (unwords obj) <> " tmp.s -o tmp"
18 | maybe (Left "The command did not execute successfully", x) ((, x) . Right) <$> execStdOut "./tmp"
19 |
--------------------------------------------------------------------------------
/test/Tests/Utils.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Tests.Utils (
3 | runTests,
4 | runTestsEx,
5 | Test (..),
6 | (~:),
7 | (~?=),
8 | exitCode,
9 | exec,
10 | execStdOut,
11 | execErrFin,
12 | clean
13 | ) where
14 |
15 | import qualified Control.Foldl as F
16 | import Control.Monad (void, when, zipWithM)
17 | import Data.Bool (bool)
18 | import qualified Data.Text as DT
19 | import System.Directory (doesDirectoryExist, doesFileExist,
20 | removeDirectoryRecursive, removeFile)
21 | import Test.Hspec (parallel)
22 | import Test.Hspec.Contrib.HUnit (fromHUnitTest)
23 | import Test.Hspec.Core.Runner (Config (..), defaultConfig,
24 | evaluateSummary, runSpec)
25 | import Test.HUnit (Test (..), (~:), (~?=))
26 | import qualified Turtle as T
27 |
28 | {-# INLINE cfg #-}
29 | cfg :: Config
30 | cfg = defaultConfig { configPrintCpuTime = True }
31 |
32 | runTests :: Test -> IO ()
33 | runTests ts = runSpec (parallel $ fromHUnitTest ts) cfg >>= evaluateSummary
34 |
35 | exitCode :: (Int -> a) -> a -> T.ExitCode -> a
36 | exitCode _ x T.ExitSuccess = x
37 | exitCode f _ (T.ExitFailure n) = f n
38 |
39 | exec :: T.MonadIO m => DT.Text -> m T.ExitCode
40 | exec = flip T.shell T.empty
41 |
42 | execStdOut :: T.MonadIO m => DT.Text -> m (Maybe T.Text)
43 | execStdOut cmd = fmap T.lineToText <$> T.fold (T.inshell cmd T.empty) F.head
44 |
45 | execErrFin :: T.MonadIO m => DT.Text -> m ()
46 | execErrFin cmd = T.shell cmd T.empty >>= exitCode (\x -> void $ T.die (cmd <> " failed with exit code: " <> T.repr x)) (return ())
47 |
48 | runTestsEx :: (Eq a, Show a) => [(IO (a, String), a)] -> IO ()
49 | runTestsEx ts = putStrLn "\n\n== Unit Tests started ==" >> zipWithM (\(t, e) i -> fmap (\(ec, t') -> (~:) ("test: #" ++ show i ++ ": " ++ t' ++ "\"") $ (~?= e) ec) t) ts ms >>= runTests . TestList
50 | where
51 | ms = take (length ts) $ iterate (+1) (1 :: Int)
52 |
53 | clean :: [FilePath] -> IO ()
54 | clean = mapM_ $ \x -> (>>=) (doesFileExist x) $ flip bool (removeFile x) $
55 | doesDirectoryExist x >>= flip when (removeDirectoryRecursive x)
56 |
--------------------------------------------------------------------------------
/test/Tests/csrc/test_func1.c:
--------------------------------------------------------------------------------
1 | #include "test_utils.h"
2 | #include
3 |
4 | int test_func1()
5 | {
6 | return 0 > printf("%s::%s(): [OK]\n", __FILE__, __func__);
7 | }
8 |
--------------------------------------------------------------------------------
/test/Tests/csrc/test_func2.c:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 | #include
4 |
5 | int test_func2(int n)
6 | {
7 | if (n < 2) return n;
8 |
9 | const size_t size = n - 3;
10 | bool* p = calloc(size, sizeof(bool));
11 |
12 | printf("%s::%s(%d) outputs: \"", __FILE__, __func__, n);
13 |
14 | for (size_t i = 0; i < size; ++i) {
15 | if (!p[i]) {
16 | for (size_t j = i + 1; j < size; ++j) {
17 | if (!((j + 2) % (i + 2))) p[j] = true;
18 | }
19 | printf("%lu ", i + 2);
20 | }
21 | }
22 |
23 | puts("\": [OK]");
24 | free(p);
25 | p = NULL;
26 |
27 | return 0;
28 | }
29 |
--------------------------------------------------------------------------------
/test/Tests/csrc/test_func3.c:
--------------------------------------------------------------------------------
1 | #include
2 |
3 | int64_t sum7(int64_t a, int64_t b, int64_t c, int64_t d, int64_t e, int64_t f, int64_t g)
4 | {
5 | return a + b + c + d + e + f + g;
6 | }
7 |
8 | int64_t sum16(int64_t a,int64_t b ,int64_t c,int64_t d,int64_t e,int64_t f, int64_t sta,int64_t stb, int64_t stc, int64_t std, int64_t ste, int64_t stf, int64_t stg, int64_t sth, int64_t sti, int64_t stj)
9 | {
10 | return a + b + c + d + e + f + sta - stb + stc - std + ste - stf + stg - sth + sti - stj;
11 | }
12 |
--------------------------------------------------------------------------------
/test/Tests/csrc/test_func4.c:
--------------------------------------------------------------------------------
1 | #include
2 |
3 | int64_t sum16(int64_t a,int64_t b ,int64_t c,int64_t d,int64_t e,int64_t f, int64_t g,int64_t h,int64_t i, int64_t j, int64_t k, int64_t l, int64_t m, int64_t n, int64_t o, int64_t p)
4 | {
5 | return a + b + c + d + e + f + g + h + i + j + k + l + n + m + o + p;
6 | }
7 |
--------------------------------------------------------------------------------
/test/Tests/csrc/test_utils.h:
--------------------------------------------------------------------------------
1 | #ifndef INCLUDED_HTCC_TEST_UTILS_H
2 | #define INCLUDED_HTCC_TEST_UTILS_H
3 |
4 | #ifndef __STDC_VERSION__
5 | # define __func__ __FUNCTION__
6 | #elif __STDC_VERSION__ < 199901L
7 | # define __func__ __FUNCTION__
8 | #endif
9 |
10 | #endif
11 |
--------------------------------------------------------------------------------