├── .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 |
8 | 9 | CI 10 | 11 | 12 | CodeFactor 13 | 14 | 15 | 16 | 17 | Architecture 18 | 19 | License 20 | 21 | 22 |
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 | 73 | 74 | 75 | 76 | 78 | 79 | 80 | 81 | 95 | 96 | 97 |
CommandOutput
$ echo 'int main() { return 1 * 2 + 4; }' |\
 77 |     stack exec htcc -- /dev/stdin --visualize-ast
AST graph of the some calculation
$ 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
AST graph of FizzBuzz
98 | 99 | ## Appearance of operations 100 | 101 |

102 | an gif animation image of operations 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 | [![FOSSA Status](https://app.fossa.com/api/projects/git%2Bgithub.com%2Ffalgon%2Fhtcc.svg?type=large)](https://app.fossa.com/projects/git%2Bgithub.com%2Ffalgon%2Fhtcc?ref=badge_large) 193 | 194 | ## References 195 | 196 |
    197 |
  1. JTC1/SC22/WG14. (2011). N1570 Commitee Draft [online]. Available from: PDF, HTML.
  2. 198 |
  3. 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.
  4. 199 |
  5. Rui Ueyama. (2019). 低レイヤを知りたい人のためのCコンパイラ作成入門 [online]. Available from: https://www.sigbus.info/compilerbook.
  6. 200 |
  7. 前橋和弥. (2009). プログラミング言語を作る. 技術評論社.
  8. 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 | --------------------------------------------------------------------------------